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FOREWORD 

In  an  ongoing  effort,  the  Defense  Logistics  Agency  (DLA)  Operations 
Research  and  Economic  Analysis  Management  Support  Office,  DLA-DORO, 
has  developed  and  fielded  versions  of  the  Quality  Effectiveness 
Sensing  Technique  (QUEST)  Model  for  the  Quality  Assurance  (QA)  mission 
with  Contract  Administration  Services.  This  report  documents  the 
logic,  structure  and  code  for  QUEST  release  3.0. 

QUEST  release  3.0  measures  the  effectiveness  of  the  contractor's  QA 
operations  by  comparing  the  contractor's  key  indicators  with  those  of 
similar  contractors  (or  peers).  Based  on  those  peer  comparisons  and 
trends,  an  effectiveness  score  for  each  indicator  is  computed  and  a 
weighted  average  of  all  indicators  produces  a  bottom  line 
effectiveness  rating. 

Release  3.0  was  validated  by  incorporating  the  profound  knowledge  of 
experts  in  the  weighting  factors  and  program  logic.  A  Study  Advisory 
Group,  consisting  of  field  and  Headquarters  QA  personnel  guided  the 
effort.  A  statistical  test  was  passed  which  compared  QUEST  release 
3.0  results  with  expert  opinion  on  certain  contractors. 

Because  of  the  track  record  of  earlier  releases,  the  use  of 
knowledgeable  experts  in  the  development  process  and  the  results  of 
validity  tests,  it  is  concluded  that  QUEST  3.0  is  implementable ,  valid 
and  meets  the  objective  of  measuring  contractor  QA  effectiveness.  It 
is  recommended  that  release  3.0  be  implemented  throughout  the  Defense 
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EXECUTIVE  SUMMARY 


In  an  ongoing  effort,  the  Defense  Logistics  Agency  (DLA) 
Operations  Research  and  Economic  Analysis  Management  Support  Office, 
DLA-DORO,  has  developed  and  fielded  versions  of  the  Quality 
Effectiveness  Sensing  Technique  (QUEST)  Model  for  the  Quality 
Assurance  (QA)  mission  with  Contract  Administration  Services.  This 
report  documents  the  logic,  structure  and  code  for  QUEST  release  3.0. 

The  major  differences  between  release  3.0  and  earlier  versions 
are  as  follows.  First,  release  3.0  focuses  exclusively  on  contractor 
QA  effectiveness  and  has  no  measures  for  in-house  program 
effectiveness.  Secondly,  this  version  is  based  on  the  new  In-Plant 
Quality  Evaluation  Program  rather  than  its  predecessor,  Contract 
Quality  Assurance  Program.  Finally,  the  indicators  used  by  release 
3.0  are  those  currently  available  in  the  revised  Quality  Assurant 
Management  Information  System. 

QUEST  3.0  computes  measures  of  effectiveness  using  an  analytical 
technique  called  Technique  for  Order  Preference  by  Similarity  to  Ideal 
Solution  (TOPSIS) .  TOPSIS  was  used  in  earlier  releases  to  compute  a 
"Product"  Score,  evaluating  the  potential  for  nonconforming  product. 
TOPSIS  produces  percentage  scores  on  a  scale  of  0-1C0  percent  for 
seven  key  indicators  by  comparing  a  contractor's  QA  data  with  that  of 
similar  contractors  and  also  by  computing  trends.  Based  on  this  peer 
comparison  and  evidence  of  improvement  (or  lack  thereof)  ,  the 
contractor  is  measured  and  reports  are  generated  to  QA  supervisors  and 
managers . 

Release  3.0  was  validated  by  incorporating  the  profound  knowledge 
of  experts  in  the  weighting  ractors  and  program  logic.  A  Study 
Advisory  Group,  consisting  of  field  and  Headquarters  QA  personnel 
guided  the  effort.  A  statistical  test  was  passed  wh!ch  compared  QUEST 
release  3.0  results  with  expert  opinion  on  certain  contractors. 

Because  of  the  track  record  of  earlier  releases,  the  use  of 
knowledgeable  experts  in  the  development  process  and  t.he  validation 
test  results,  it  is  concluded  that  QUEST  3.0  is  implementable ,  valid 
and  meets  the  objective  of  measuring  contractor  QA  effectiveness.  It 
is  recommended  that  release  3.0  be  implemented  throughout  the  Defense 
Contract  Management  Command  (DCMC) . 
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I. 


INTRODUCTION 


A.  Background.  Quality  Assurance  Effectiveness  Sensing  Technique 
(QUEST)  was  developed  to  provide  supervisors  and  upper  management  a  tool  to 
measure  and  monitor  the  effectiveness  of  in-plant  quality  operations  at 
Defense  Contract  Administration  Services  (DCAS) ,  Developed  in  the  Fiscal 
Year  (FY)  1987  -  1988  timeframe,  QUEST  was  implemented  in  FY  89.  An 
improved  version  of  QUEST,  release  2.0,  was  implemented  in  March  1990. 
These  versions  of  QUEST  were  based  on  DLAM  8200.1,  Contract  Quality 
Assurance  Program  or  CQAP.  In  FY  90,  a  transition  from  CQAP  to  a  new 
program  began  within  DCAS.  As  the  new  program,  called  In-Plant  Quality 
Evaluation  (IQUE) ,  phased  in,  QUEST  2.0  has  become  obsolete,  requiring  a 
new  version  of  the  model. 

B .  Problem  Statement 


1.  To  develop  a  plan  to  modify  QUEST  2.0  to  be  compatible  with 
the  new  policies  and  procedures  under  IQUE. 

2.  To  establish  necessary  data  requirements  to  support  a  new 
release  of  QUEST. 

3.  To  develop  a  new  release  of  QUEST  to  satisfy  Defense 
Logistics  Agency  (DLA)  commitments  to  the  Department  of  Defense  (DoD)  to 
establish  measures  of  effectiveness  for  Quality  Assurance  (QA) . 

C.  Objectives 

1.  To  develop  a  workable,  valid  model  that  measures  QA 
effectiveness  under  IQUE. 

2 .  To  influence  the  functional  description  of  the  QA  Management 
Information  System  (QAMIS)  to  assure  necessary  data  is  available  to  measure 
effectiveness . 

D.  Scope .  QUEST  3.0  will  apply  to  all  active  contractors  under  the 
surveillance  of  the  Defense  Contract  Management  Command  (DCMC,  formerly 
DCAS).  QUEST  release  3.0  will  be  limited  to  providing  measures  of 
contractor  QA  effectiveness  only.  Measures  relating  to  the  effectiveness 
of  the  government  QA  program  will  be  addressed  in  this  report  but  deferred 
for  future  decisions. 

II.  METHODOLOGY 


A.  General  Discussion 

QUEST  2.0  contained  two  primary  effectiveness  measures,  namely  a  program 
score  and  a  product  score.  Program  scores  were  designed  to  measure  the 
effectiveness  of  CQAP  operations  and  were  a  report  card  on  the  government 
surveillance  system.  Product  scores  were  designed  to  measure  product 
conformance  to  requirements  and  were  a  report  card  on  the  contractor. 
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Under  the  IQUE  philosophy,  the  Government  and  the  contractor  work  more  as  a 
team,  less  as  adversaries.  As  such,  it  is  increasingly  difficult  to 
measure  each  independently.  The  goal  of  IQUE  is  to  place  less  emphasis  on 
inspecting  final  product  and  to  increased  emphasis  on  controlling 
production  processes.  Since  each  contractor  has  a  unique  set  of  processes, 
IQUE  is  very  flexible  and  tailored  to  the  contractor  by  the  government 
Quality  Assurance  Representative  (QAR) .  The  regimented,  standardized 
approach  of  CQAP  lent  itself  more  to  measurement.  IQUE  will  be  more 
difficult  to  measure  from  a  program  perspective. 

These  issues  were  discussed  by  the  QUEST  3.0  Study  Advisory  Group  (SAG) 
(Appendix  A).  Because  of  time  constraints  and  the  perceived  difficulty  of 
developing  program  measures  for  IQUE,  it  was  decided  that  release  3.0 
shou’id  be  limited  to  measuring  contractor  effectiveness.  If  the  IQUE 
program  is  successful  and  hence  effective,  the  results  will  be  evident  from 
contractor  effectiveness  scores.  Continuous  improvement  of  contractor 
effectiveness  measures  is  a  signal  of  the  effectiveness  of  IQUE.  The  SAG 
felt  that  measures  of  IQUE  program  effectiveness  should  not  be  terminated, 
only  given  lower  priority  than  contractor  effectiveness.  The  group 
recommended  that  program  effectiveness  be  considered  as  an  add-on  at  a 
later  date,  if  feasible. 

B.  Contractor  Effectiveness.  Like  earlier  versions  of  QUEST, 
release  3.0  is  based  on  the  premise  that  available  data  only  signals 
instances  of  ineffectiveness.  Thus  indicators  are  called  negative 
indicators.  The  more  negative  indicators  associated  with  a  particular 
contractor,  the  less  effective  that  contractor  is  perceived  to  be.  QUEST 
3.0  will  capture  data  on  negative  indicators  of  effectiveness  and  translate 
that  data  to  measures  of  effectiveness.  The  indicators,  currently 
available  in  the  QAMIS,  used  by  QUEST  3.0  are: 

1.  Corrective  Action  Requests  (CAR!.  Verbal,  written  and 
escalation  CARs  (methods  C,  D,  and  E)  are  weighted  and  added  to  produce  an 
indicator  value  for  CARs.  Relative  to  a  method  C  CAR,  the  sum  of  verbal 
and  written  CARs  are  weighted  4  to  1  (4  verbal  or  written  CARs  count  the 
same  as  a  method  C) .  Two  method  C  C<\Rs  have  equal  weight  to  a  method  D  and 
a  method  E  has  equal  weight  to  method  C.  Weighting  factors  were  determined 
by  the  SAG. 


2.  Product  Quality  Deficiency  Reports  (PODR).  PQDR  indicators 
are  used  exactly  the  same  way  that  earlier  versions  of  QUEST  evaluated 
Materiel  Deficiency  Reports,  with  two  exceptions.  PQDRs  charged  against  an 
Indefinite  Delivery  Type  Contract  or  Basic  Ordering  Agreement  (Procurement 
Instrument  Identification  Number  Type  "D"  or  "G"  contracts)  are  not 
discounted  for  age  and  carry  full  weight.  Also  PQDRs  with  defect  code  "X," 
contractor  refuses  to  investigate,  are  counted  as  valid  PQDRs.  For 
additional  information  on  PQDR  processing,  see  Appendix  C  within  Reference 


3.  Product  Audit.  The  ratio  of  product  audit  counts  that 
resulted  in  CARs  to  total  product  audit  counts  is  converted  to  a  percentage 
value.  This  indicator  represents  the  percentage  of  product  audits  that 
contain  contractual  nonconformances. 
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4.  Waivers .  The  number  of  waivers  submitted  to  the  QAR  and 
reported  in  the  QAMIS  is  the  fourth  indicator.  Waivers  are  after  the  fact 
requests  to  the  Contracting  Officer  to  modify  or  eliminate  contractual 
requirements . 

5.  Material  Review  Board  (MRB)  Actions.  The  number  of  MRB 
actions  reported  by  the  QAR  is  an  indicator  that  has  not  been  modified  from 
earlier  versions  of  QUEST.  MRB  actions  are  minor  nonconformances  reported 
by  the  contractor. 

6.  Deviations .  The  number  of  deviations  submitted  to  the  QAR 
and  reported  monthly  in  the  QAMIS  is  the  sixth  indicator.  Earlier  versions 
of  QAMIS  reported  combined  waivers  and  deviations.  With  the  new  QAMIS, 
these  data  elements  are  reported  separately  and  are  used  separately  in 
QUEST  3.0.  Deviations  are  before-the-fact  requests  to  deviate  from 
contractual  requirements  (i.e.  after  the  contract  is  awarded  but  before 
actual  production  of  the  item) . 

7.  Engineering  Change  Proposals  (ECP).  ECPs  submitted  to  the  QAR 
are  the  last  indicator  used  to  evaluate  contractor  effectiveness.  This 
indicator  remains  unchanged  from  earlier  versions  of  QUEST.  ECPs  are 
formal  requests  by  the  contractor  to  permanently  change  the  specifications. 

8.  Total  Score.  A  composite  total  score  is  generated  in  QUEST 
by  taking  a  weighted  average  of  the  preceding  seven  indicators,  listed  in 
the  order  of  decreasing  weight.  Weights  were  generated  by  the  SAG, 
reflecting  the  relative  importance  of  each  indicator  in  viewing  contractor 
quality  performance.  Details  are  shown  in  Appendix  B,  page  B-33, 

9 .  Indicator  Measurement 

Translation  from  raw  indicator  data  to  a  consistent  measure  of 
effectiveness  is  done  using  the  Technique  for  Order  Preference  by 
Similarity  to  Ideal  Solution  (TOPSIS),  developed  by  Dr.  Ching-Lai  Hwang  of 
Kansas  State  University  [2,  3],  TOPSIS  is  used  to  produce  scores  on  a 
scale  of  0-100  percent  from  multiple  criteria  by  measuring  each  criteria 
from  a  set  of  "ideal"  and  "negative  ideal"  points.  "Ideal"  conditions  are 
defined  as  the  best  possible  values  for  each  criteria  or  attribute. 
"Negative  ideal"  conditions  are  the  worst  possible  values  for  each 
parameter  or  indicator.  Ideal  and  negative  ideal  conditions  were  defined 
by  the  SAG.  Definitions  for  ideal/negative  ideal  vary  depending  on  whether 
the  contractor  is  considered  to  bp  "normal"  or  a  "problem"  contractor. 

A  "problem"  contractor  is  considered  to  be  a  contractor  that  has  a  history 
of  chronic  performance  problems.  QUEST  assigns  additional  emphasis  to  the 
trend  component  of  the  measurement  process  for  these  contractors.  To  be 
viewed  by  QUEST  3.0  as  a  problem  contractor,  two  of  the  following 
conditions  must  apply.  First,  the  contractor  is  on  the  Contractor  Alert 
List  (for  any  reason).  The  Alert  List  is  compiled  by  DCMC  to  warn 
acquisition  elements  of  contract  administration  problems  experienced. 
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Second,  the  contractor  has  a  history  of  relatively  high  incidence  of  valid 
PQDRs.  Third,  the  contractor  received  a  method  C  CAR  within  the  last  three 
months.  Fourth,  the  contractor  received  a  method  D  Corrective  Action 
Request  within  the  last  year.  Finally,  th?  co-.cractoi  received  a  method  E 
CAR  within  the  last  three  months. 

The  Trend  component  in  the  measure  of  effectiveness  carries  half  the  weight 
in  overall  indicator  measurement  for  a  normal  contractor  and  '0  percent  of 
the  weight  for  a  problem  contractor.  Trend  is  calcinated  based  on  the  last 
six  months  of  activity.  Activity  is  defined  as  any  month  when  more  than 
two  hours  of  total  government  QA  surveillance  takes  place.  If  the  slope  of 
the  trend  line  is  upward  or  positive,  QUEST  views  this  as  unfavorable  and 
penalizes  the  contractor.  Downward  or  negative  trends  result  in  high 
effectiveness  scores. 

The  second  part  of  the  measurement  process  is  to  measure  the  contractor's 
data  in  relation  to  the  contraccor's  "peers."  If  the  contractor's 
indicators  are  higher  than  those  of  ”>  eers , "  QUEST  produces  low 
effectiveness  scores.  Lower- than-pee rs  indicators  result  in  high 
effectiveness  scores.  Additional  information  on  the  Peer  Processing  is  in 
Appendix  F  of  Reference  4.  In  all  cases,  except  PQDR  for  problem 
contractors,  ideal  condition?  are  minus  three  standard  deviations  for  trend 
and  peer  comparison.  Negative  ideal  conditions  are  plus  three  standard 
deviations.  A  +3  standard  deviation  means  that  the  trend  or  peer 
comparison  is  three  standard  deviations  above  average.  A  -3  standard 
deviation  indicates  that  the  contractor's  trend  or  peer  comparison  is  three 
standard  deviations  below  average.  Details  are  found  in  Appendix  B,  page 
B-33 . 

TOPSIS  mathematically  converts  trend  and  peer  comparison  results  in'o  a 
single  measure  by  computing  two  distances.  A  given  contractor's  trend  is 
compared  to  ideal  and  negative  ideal  trend.  Alsu,  the  indicator  value 
relative  to  peers  for  the  contractor  is  compared  to  the  ideal  and  negative 
ideal  conditions.  The  difference  between  the  contractor's  actual  trend  and 
peer  comparison  to  ideal  points  is  called  a  distance.  TOPSIS  combines  the 
distances  into  a  ratio  of  a  part  to  a  whole,  forming  a  score  between  0 
percent  and  100  percent.  Specifically ,  TOPSIS  scores  are  the  ratio  of 
distance  from  negative  ideal  to  the  total  distance  from  both  positive  and 
negative  ideal.  The  resulting  scores  are  such  that  low  scores  indicate 
proximity  to  negative  ideal  (poor  effectiveness)  and  high  ratios  indicate 
closeness  to  ideal  conditions  (high  effectiveness). 

10.  Reports 

QUEST  3.0,  like  QUEST  2.0,  provides  data  to  users  in  three  ways.  A 
district  level  report  is  generated  to  a  printer.  This  report  contains  a 
one  page  summary  for  each  unique  organization  (section)  in  the  district 
each  month.  An  example  is  shown  in  Table  1  .  Secondly,  though  the 
Mechanization  of  Reports  Distribution  System  (M0RDS) ,  each  division 
receives  the  same  hard  copy  report  for  the  organizations  withm  the 
division.  For  users  that  have  terminals  and  access  to  the  district's  DMINS 
system,  QUEST  data  is  electronically  available  in  a  menu-driven  format. 
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SAMPLE  QUEST  3.0  REPORT 
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The  QUEST  3.0  report  is  similar  to  previous  QUEST  reports  [1,  4]'. 
Generally,  for  QUEST  3.0,  sections  dealing  with  Program  Score  (Red  Flags) 
have  been  eliminated,  and  additional  descriptive  data  on  the  contractor  is 
provided.  Also,  historical  QUEST  scores  are  shown  to  ease  trend  analysis. 
The  following  Table  1  headings  are  defined. 

a.  CAGE.  Commercial  and  Government  Entity  Code  identifies 
the  contractor.  If  there  is  an  asterisk  preceding  the  CAGE,  the  contractor 
has  been  labeled  by  QUEST  as  a  "problem"  contractor. 

b.  NAME.  First  ten  characters  in  the  name  field  of  the 

contractor . 

c.  OAR.  Identifies  the  government  Quality  Assurance 

Representative  in  charge  of  the  government  quality  surveillance. 

d.  COMM.  Commodity  Code  in  accordance  with  DLAM  8200.2. 

e.  PVN.  QA  Provision  Code.  A  represents  MIL-Q-9858A  or 
equivalent,  B  represents  MIL-I-45208A  and  C  is  "other." 

f.  OAS .  The  number  of  government  QA  Specialists  (QAS) 
assigned  to  the  facility.  This  number  is  computed  from  the  total 
government  QA  hours  charged  to  the  contractor  (roughly  one  man  month  equals 
149  hours)  and  may  not  be  the  actual  number  of  QASs  assigned  to  the 
contractor. 

g.  CA.  Correction  Action  Request  score. 

h.  PQDR.  Product  Quality  Deficiency  Report  score. 

i.  PA.  Product  Audit  Score. 

j.  WVRS.  Waiver  Score. 

k.  MRB.  Materiel  Review  Board  score. 

l.  DEVN.  Deviation  Score. 

m.  ECP.  Engineering  Chinge  Proposal  Score. 

n.  TOTAL  SCORE .  Weighted  average  of  the  previous  seven 
indicator  scores.  This  represents  the  overall  effectiveness  score  fof  the 
contractor. 

o.  PRIOR  MONTH.  QUEST  3.0  shows  up  to  three  prior  month 
TOTAL  SCORES  for  each  con'trabtor. 

p.  PEER  GRP.  Peer  group  identification  number  (see  Appendix 
F  of  Reference  4) .  Contractors  that  have  the  same  peer  group  number 
generally  have  the  same  commodity,  provision  and  have  roughly  the  same 
defense  contract  workload. 
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q.  PEER  RTG .  Converts  the  Total  Score  to  a  letter  grade. 
Since  not  all  peer  groups  have  the  same  pattern  of  QUEST  scores 
(nonresidents  generally  get  higher  ratings  than  resident  facilities),  the 
letter  grade  represents  a  "relative  to  peer"  effectiveness  rating.  For 
example,  an  identical  Total  Score  of  80  percent  could  translate  into  a  B,  C 
or  D  rating,  depending  on  the  peer  performance. 

III.  ANALYSIS 

Prior  to  implementation,  it  was  determined  that  because  of  the  significant 
changes  to  QUEST,  a  revalidation  was  necessary.  The  original  QUEST  version 
4  was  validated  using  a  correlation  technique  matching  QUEST  scores  to  expert 

evaluations  [1].  Because  of  the  compressed  schedule  for  QUEST  3.0,  a 

similar  but  simpler  nonparametric  analytical  process  was  used  to  determine 
if  the  QUEST  scores  reasonably  matched  the  perception  of  experts.  If  the 
QUEST  effectiveness  rating  correlated  with  expert  opinion  to  an  adequate 
degree,  the  model  was  considered  valid  by  the  SAG. 

A  Mann-Whitney  raiik  sum  test  [5]  was  conducted.  Mann-Whitney  tests  to 
determine  if  an  effect  could  be  caused  by  random  coincidence  or  if  an 
effect  is  "real."  In  statistical  jargon,  a  "real"  effect  is  called 
"statistically  significant."  We  tested  to  see  if  the  agreement  between 
experts  and  QUEST  is  statistically  significant.  Each  former  DCAS  region 
was  asked  to  produce  a  set  of  contractors  labeled  as  effective  or 
ineffective  from  a  QA  viewpoint.  These  "good"  or  "bad"  contractors  were 
evaluated  by  QUEST  for  the  September  1989  through  December  1989  timeframe 
and  four  month  average  QUEST  scores  were  computed.  Also,  the  peer  rating 
(A  through  F)  was  averaged  to  compute  the  equivalent  of  a  Grade  Point 
Average  on  a  scale  of  0.0  to  4.0  (4.0  equals  straight  A  ratings  for  four 
consecutive  months).  The  hypothesis  that  QUEST  3.0  was  unable  to 
distinguish,  overall,  between  effective  and  ineffective  contractors  was 
overwhelmingly  rejected.  The  level  of  significance  for  nonresident 
contractors  was  less  than  .0001  and  for  resident  contractors  the  level  of 
significance  was  .0039.  In  other  words  the  probability  of  observing  the 
degree  of  agreement  between  QUEST  and  the  expert  purely  by  chance  is  less 
than  .0001  and  .0039  respectively.  QUEST  3.0  better  matched  expert  opinion 
with  the  peer  rating  than  the  Total  Scores.  It  appeared  that  the  letter 
grades  are  more  accurate  in  assessing  performance  than  the  numerical 
ratings.  Figures  1  and  2  graphically  summarize  the  test  results.  For 
example,  Figure  1  shows  that  contractors  identified  as  poor  performers  most 
frequently  received  a  "D-"  QUEST  rating  and  good  performers  most  frequently 
were,  rated  as  "A." 

In  an  isolated  number  of  cases,  there  is  a  disconnect  between  the  QUEST 
rating  and  the  expert's  perception.  A  perceived  "bad"  contractor  may  have 
received  an  excellent  QUEST  rating  and  a  perceived  "good"  contractor  may  be 
viewed  unfavorably  by  QUEST.  However,  in  most  cases,  the  two  evaluations 
agreed,  causing  sufficient  correlation  to  pass  statistical  tests.  Based  on 
this  test,  prior  experience  with  QUEST  2.0  and  knowledge  of  the  changes 
under  QUEST  3.0,  the  SAG  concluded  that  QUEST  3.0  was  valid. 
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IV. 


CONCLUSIONS 


Since  QUEST  3.0  is  a  continuation  of  an  established  program,  was 
designed  with  significant  participation  of  experts,  and  has  passed 
statistical  tests  of  validity,  it  is  concluded  that: 

o  QUEST  3.0  is  implementable .  It  requires  use  of  existing  data  only 
and  has  been  run  in  a  laboratory  environment  at  DLA-DORO. 

o  QUEST  3.0  is  valid.  its  results  match  the  perception  of  experts 
in  the  field. 

o  QUEST  3.0  adequately  measures  the  QA  effectiveness  of  DCMC 
contractors . 

V.  RECOMMENDATION .  It  is  recommended  that  QUEST  3.0  be  implemented 
throughout  DCMC.  It  is  also  recommended  that  a  feasibility  study  be 
conducted  after  IQUE  is  fully  implemented  to  assess  >  easures  of  in-house  QA 
effectiveness  or  program  effectiveness. 

VI.  BENEFITS 

The  incremental  benefits  of  QUEST  3.0  from  version  2.0  are  based  on  the 
following  logic.  QUEST  3.0  has  been  selected  as  one  of  ten  primary 
workload  indicators  in  the  proposed  QA  Resource  Model  currently  under 
development.  It  is  conservatively  estimated  that  the  use  of  this  tool  to 
justify  and  allocate  quality  resources  could  achieve  comparable 
effectiveness  with  1  percent  fewer  resources.  Assuming  that  there  are 
7,000  QA  specialists  with  an  average  grade  of  GS-10,  step  5  with  29.55 
percent  fringe  benefits,  QUEST  3.0  benefits  are: 

1  x  1%  x  7,000  x  $32, 098/year  x  1.2955 
10 

$291,080  per  year 

In  addition  to  these  quantifiable  benefits,  QUEST  3.0  provides  a  more 
accurate  measure  of  the  contractor  QA  program.  This  information  will  be 
valuable  to  first  line  supervisors  and  upper  management  to  evaluate  the  in- 
house  IQUE  program,  to  determine  when  and  where  remedial  action  is  needed 
and  to  warn  other  acquisition  elements  where  the  IQUE  program  is  not 
working.  By  measuring  effectiveness  based  on  the  seven  negative  indicators 
(paragraph  II. B. 1-7),  the  QAR  and  the  contractor  will  take  actions  to 
reduce  the  incidence  of  these  negative  indicators,  leading  to  higher 
quality  products  and  improved  customer  satisfaction. 

VII.  IMPLEMENTATION 

An  implementation  plan  was  developed  and  approved  by  the  SAG.  It  was 
proposed  that  DLA-DORO  maintain  the  FORTRAN  source  code  with  the  Job 
Control  Language  maintained  by  the  DLA  Systems  Automation  Center  (DSAC) . 
DSAC  is  responsible  for  exporting  release  3.0  to  the  various  field 
activities.  Prior  to  release,  the  model  will  undergo  environmental  testing 
on  actual  field  data  at  one  site. 
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In  September  1990,  QUEST  3.0  was  tested  in  a  production  environment  on 
DCMC-West  data.  All  aspects  of  the  model  were  acceptable  except  the  DMINS 
process.  This  part  of  the  model  must  be  installed  by  the  Systems  Branch, 
Program  and  Systems  Management  Division,  Directorate  of  Quality  Assurance 
(DLA-QRS)  on-site  and  will  be  done  in  conjunction  with  site  visits  on  other 
programs  to  conserve  travel  funds . 
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//G0R6040B  JOB  (604O.G0R ). 'GROVER '. CLASS=3 ,MSGCLASS=V 
//* 

//STFP1  EXEC  FORTVCG . FVREGN=2500K ,GOREGN=2000K. 

//  PARM . GO* ' LET , NORES . EP=MAIN, SI ZE=500000' 

//FORT , SYSIN  OD  ’ 

CHARACTFR-3  FIL1 ,M03 
CHARACTER’S  FSCM1 

CHARACTER* 1  FIL2 . FIL4 , FI L5 . FIL6 , FRCN. FPRI . FAC , FOEF , PI INTP 

CHARACTER* 12  FIL3 

CHARACTER*2  YR.FY 

CHARACTER* 11  FIL7 

CHARACTER*4  F0AYS1 

CHARACTER*26  FIL8 

CHARACTER* 13  FIL9 

1  FORMAT (A3, A5.A1 ,A1 .A  12. A1 .A1.A2, A3.4A1.A1 1 , A4 . A2G.A2, A1 ,A13) 

2  READ( 1,1, END=3 )  FIL 1 , FSCM1 . F IL2 , FRCN. FIL3 . FPRI . 

+  FIL4.YR,M03,FIL5.FAC,FIL6,FDEF. 

+  FIL7,FDAYS1,FIL8,FY,PIINTP,FIL9 

IF  1PRCN.E0. 'S' )  THEN 

I F ( ( P 1 INTP  , EO .  'O’)  .OR.  ( PI INTP  ,E0.  'G'))  FY*YR 
1 F ( ( FY (  1 : 1 )  . LT .  '0')  .OR.  (FY(1:1)  .GT.  '9'))  FY  =  YR 
I F ( ( FY ( 2 : 2 )  . LT .  '0')  .OR.  (FY(2:2)  .GT.  '9'))  FY*YR 
WRITE (2.  1)  FIL1 .FSCM1 , FI L2, FRCN, FIL3, FPRI. 

+  F I L4 . YR , M03 , F I L5 . FAC , F I L6 , FDEF , 

+  FIL7.FDAYS1 . FIL8 , FY , FIL9 

ENDIF 
GOTO  2 

3  END 


/' 

//* 

/ / GO . FT01 FOO 1  DO  DSN*GOR . GROVER . MDR . ATLCUM . MAY90. 
//  DISP=SHR 

//GO . FT02F001  DD  DSN=GOR . GROVER . ATL .MDRTEMP1 , 


//* 

// 

// 

// 

// 


D ISP* (NEW. CAT LG, DELETE  ) , 

DISP=( .PASS) , 

DCB=(RECFM=FB,LRECL=90,BLKSIZE= 18000), 
UNIT*WORKD . SPACE* (CYL , ( 1 , 1 ) . RLSE ) , 
V0L=SER=W0RKW1 


/ /GO . FTOGFOOI  DD  SYSOUT** 
//SYSOUT  OD  SYSOUT*  * 
//SYSUDUMP  OD  SYSOUT  =  * 
//SYSPRINT  OD  SYSOUT** 

//* 

//STEP2  EXEC  PGM* I ERRCOOO 
//SORTLIB  DD 


DD 

DD 

DD 


//SYSUDUMP  DD 
//SORTMSG  DD 
//SYSOUT 
//SORTIN 
// 

//SORTOUT 

// 

//* 

// 

// 

// 

// 

/ /S0RTWK01 
//S0RTWK02 
/ /S0RTWK03 


DSN*SYS1 .SORTLIB. DISP=SHR 
SYSOUT** 

SYSOUT** 

SYSOUT*- 

DSN=GOR . GROVER . ATL . MDRTEMP 1 . 

DISP=OLD 

DSN=GOR . GROVER . ATL . MDRTEMP2 , 

DISP*( , PASS  ) , 

DISP=(NEW, CATLG. DELETE)  . 

UNIT=WORKD . 

DCB* (RECFM*FB , LRECL=90, BLK5I ZE* 18000) . 
SPACE=(TRK. (99,9) , RLSE) . 

V0L*SER=V'0RKW1 

DD  UNIT=WORKO,SPACE=(TRK, 10) 

DD  UNIT=WORKD,SPACE=(TRK, 10) 

DD  UNIT=WORKD,SPACE=(TRK, 10) 


//SYSIN  OD 

SORT  FI  ELDS* ( 10.8.CH, A, 19 , 3 , CH , A , 18 , 1 , CH, A ) 

//* 

/* 

//STEP3  EXEC  FORTVCG , FVREGN=2500K , G0REGN*2000K , 

//  PARM. GO* 'LET, NORES, EP=MAIN, SIZE =500000' 

//FORT. SYSIN  DD  * 

C  THERE  IS  A  BUG  IN  THIS  SECTION  ON  REOPENED  MDRS  THAT  OCCURS  IN 
C  REGIONS  THAT  HAVE  MULTIPLE  DODAACS  ENTERING  MDRS.  THE  SCR  THAT 
C  CHANGED  REOPENING  MDRS  ELIMINATES  THE  BUG.  BUG  ONLY  APPLIES  TO 
C  OLD  DATA. 

CHARACTER* 10  FIL1(2) 

CHARACTER*7  CNBRA(2 ) 

CHARACTER* 1  CNBRB( 2 ) 

CHARACTER*3  CNBRC(2) 

CHARACTER* 1  FIL2(2) 

CHARACTER* 1  PRI(2) 

CHARACTER* 1  FIL3(2) 

CHARACTER*2  YR(2) 


00010022 

00020004 

00030004 

00040004 

00050004 

00060004 

00070004 

00080034 

00090004 

00100004 

00110004 

00120004 

00130004 

00140034 

00150034 

00160004 

00170004 

00180034 

00190004 

00200034 

00201034 

00210013 

00220013 

00230004 

00240004 

00250004 

00260004 

00270004 

00280004 

00290004 

00300035 

00310004 

00320035 

00330029 

00340029 

00350004 

00360022 

00370022 

00380004 

00390004 

00400004 

00410004 

00420004 

00430004 

00440004 

00450004 

00460004 

00470004 

00480035 

00490005 

00500035 

00510029 

00520029 

00530022 

00540004 

00550024 

00560022 

00570004 

00580004 

00590004 

00600004 

00610004 

00620004 

00630004 

00640004 

00650004 

00660004 

00661025 

00662025 

00663025 

00664025 

00670004 

00680004 

00690004 

00700004 

00710004 

00720004 

00730004 

00740004 
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CHARACTER*3  M03(2) 

00750004 

CHARACTER* 1  FIL4(2) 

00760004 

CHARACTER* 1  FAC(2) 

00770004 

CHARACTER* 1  FIL5(2) 

00780004 

CHARACTER* 1  F0EF(2) 

00790004 

CHARACTER* 1 1  FIL6(2) 

00800004 

INTEGER  FOAYS(2) 

00810004 

CHARACTER* 16  FIL7A(2) 

00820004 

CHARACTER* 10  FIL7B(2) 

00830004 

CHARACTER*2  FY(2) 

00840004 

CHARACTER* 14  rjL8(2) 

00850004 

1 

FORMAT (A10,A7,A1,A3,A1,A1.A1,A2,A3,A1.A1,A1,A1, 

00860004 

+A1 1 , 14 , A  16. A  10, A2 , A 14 ) 

00870004 

READ( 1.1. END* 5)  FIL 1 ( 1 ) ,CNBRA( 1 ) ,CNBRB( 1 ) ,CNBRC( 1 ) . FIL2( 1 ) . 

00880004 

+PRI ( 1 ) , FJ L3( 1 ) , YR( 1 ) ,M03( 1 ) . FIL4( 1 ) , FAC( 1 ) , F I L5 ( l).FDEF(l), 

00890004 

+FIL6( 1 ) , FDAYS( 1),FIL7A(1) , FIL7B( 1),FY(1),FXL8{1) 

00900004 

2 

READO,  1 ,  EN0=3  )  FIL  1  (2)  ,CNBRA(2)  ,CNBRB(  2  )  ,CNBRC(  2) ,  F I L2  ( 2  )  , 

00910004 

+PRI (2),FIL3(2),YR(2), M03(2 ) ,FIL4(2),FAC(2),FIL5(2).FDEF(2), 

00920004 

+FIL6(2).FDAYS(2) , FIL7A( 2 ) , FI L7B(2 ) , FY( 2 ) . FI L8(2 ) 

00930004 

I F ( (CNBRA( 1 ) ,EQ.CNBRA(2) ) .AND. (CNBRC( 1) . E0.CNBRC(2) ) )  THEN 

00940004 

FDAYS( 1 )*FDAYS( 1)+FDAYS(2) 

00950004 

CNBRB( 1 )=CNBRB(2) 

00960004 

PRI(1 )=PRI(2) 

00970004 

FAC( 1 )=FAC(2) 

00980004 

FDEF ( 1  )  =  FDEF(2) 

00990004 

FY( 1 )=FY(2) 

01000004 

I  F ( FIL 1 ( 1 ) , LE  .  '  ')  FIL1( 1 )»FIL1(2) 

01010004 

IF(FIL2( 1 ) . LE . '  ')  FIL2( 1 )=FIL2(2) 

01020004 

I F ( FI L3( 1 ) . LE . '  ')  FIL3( 1  )  =F I L3( 2 ) 

01030004 

I F( FI L4 ( 1 ) . LE . '  ')  FIL4( 1 )=FIL4{2) 

01040004 

I F ( FIL5(  1 ) . LE . '  ')  FIL5( 1 ) *F IL5( 2 ) 

01050004 

I F ( FIL6( 1 ) . LE . '  ')  FI L6( 1 ) =F IL6( 2 ) 

01060004 

I F ( F I L7A( 1 ) . LE . '  ')  FIL7A(1)*FIL7A(2) 

01070004 

I F ( FI L7B( 1  ) . LE . '  ')  FIL7B( 1 )=FIL7B(2) 

01080004 

IF(FIL8(1).LE. '  ')  FIL8( 1 )=FIL8(2) 

01090004 

GOTO  2 

01100004 

END  IF 

01110004 

WRITE ( 2 . 1  )  F IL 1 ( 1 ) . CNBRA( 1 ) , CNBR8( 1 ) ,CNBRC( 1 ) , FI L2(  1  ) , 

01120004 

+PRI  (  1),FIL3(1),YR(1), M03 (1),FIL4(1). FAC( 1),FIL5(1), 

01130004 

+FDEF(1),FIL6(1),  FDAYS(  1),FIL7A(1),  FIL7B(  1),FY(1),FII.8(  1) 

01140004 

F I L 1 ( 1 ) *FIL1 ( 2 ) 

01150004 

CNBRA( 1 ) =CNBRA ( 2 ) 

01160004 

CNBRB( 1 ) *CNBRB( 2  ) 

01170004 

CNBRC( 1 ) =CNBRC( 2 ) 

01180004 

FIL2(  1  )  =  FIL2(2) 

01190004 

PRI ( 1 ) *PRI (2 ) 

01200004 

FIL3(1)«FIL3(2) 

01210004 

YR( 1  )  * YR( 2 ) 

01220004 

M03( 1 ) =M03( 2 ) 

01230004 

F I  L4  (  1 )  *F  I L4  ( 2 ) 

01240004 

FAC( 1 ) *FAC( 2 ) 

01250004 

F1L5( 1 )=FIL5(2) 

01260004 

FDEF ( 1 )=FDEF ( 2 ) 

01270004 

FIL6(1)=FIL6(2) 

01280004 

FDAYS( 1  )  =  FDAYS(2) 

01290004 

FIL7A( 1 )=FIL7A(2) 

01300004 

FIL7BM)*FIL7B(2) 

01310004 

FY( 1 ) *F Y( 2 ) 

01320004 

F 1 1.8 1  1  )*F I L8( 2 ) 

01330004 

GOTO  2 

01340004 

3 

WRITE( 2 . 1  )  FIL 1 ( 1 ) . CNBRA( 1 ) , CNBRB( 1 ) ,CNBRC( 1),FIL2(1), 

01350004 

+  PRI (  1  )  , F I L3( 1 ) , YR( 1 ) ,M03( 1),FIL4( 1 ) , FAC( 1 ) , F I L5 f 1), 

01360004 

+F0EF(1),FIL6(1).FDAYS(1),FIL7A(l)fFIL7B(l),FY(1),FIL8(l) 

01370004 

5 

END 

01380004 

/* 

01390004 

//* 

01400004 

//GO. 

.  FT01F001  DD  0SN=G0R. GROVER. ATL.MDRTEMP2, 

01410035 

// 

DISP=OLD 

01420005 

//GO. 

.  FT02F001  DD  DSN*GOR .GROVER . ATL .MDRTEMP3 , 

01430035 

//» 

DISP=(NEW.CATLG. DELETE), 

01440029 

// 

DISP=( .PASS) . 

01450029 

// 

DCB  =  ( RECFM=FB , LRECL*90, BLKSIZE  =  18000) , 

01460004 

// 

UNIT=WORKD. SPACE = (CYL, ( 1 , 1),RLSE). 

01470022 

// 

V0L=SER=W0RKW1 

01480022 

//GO, 

.  FT06F001  DD  SYSOUT** 

01490004 

//SYSOUT  OD  SYSOUT=* 

01500004 

//SYSUOUMP  DO  SYSOUT** 

01510004 

//SYSPRINT  DD  SYSOUT** 

01520004 

/* 

01530004 

//• 

01540004 
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//STEP4  EXEC  FORTVCG, FVREGN=2500K , GOREGN=2000K , 

//  PARM.GO= ' LET ,NORES . EP=MAIN, SIZE =500000' 

//FORT . SYSIN  DD  * 

£  »«»**«*****»»r'«***>k******'*K*«**>'C*******ft**K*j**»>'r*»********K***»***««*X 

c 

C  MODIFIED  BY  TLB  ON  10/20/87 

C 

C  INPUT:  MATERIAL  DEFICIENCY  REPORT  (MDR )  FILES  FROM  FIVE  DCASRS 

C  OUTPUT:  LISTINGS  OF  NUMBER  OF  MDRS  BY  MANUFACTURERS  BY  MONTH 

C 

£  **»**m«»lt«***«**>fc**K*K**«****«*l*'*W***»**V*atttK*IKIHW*W*ftl|'**V«*tt*»lr*Hr»*ft» 

C  DOCUMENTATION  SECTION 

£  **K«»W*«*«&M«*******«**tt********K¥*«**»*».K«****W******»*KK*M*W»»»W»K» 

c 

C  THE  PURPOSE  OF  THIS  PROGRAM  IS  TO  CREATE  AN  INPUT  FILE  FOR 

C  ADDITIONAL  PROCESSING.  THE  END  RESULT  OF  THE 

C  PROGRAM  IS  A  LISTING  WHICH  SHOWS  HOW  MANY  MATERIAL 

C  DEFICIENCY  REPORTS  (MDR)  ARE  RECEIVED  BY  THE  DCASR 

C  FOR  A  GIVEN  MANUFACTURER  IN  A  GIVEN  MONTH.  THE  LENGTH 

C  OF  TIME  BETWEEN  THE  FISCAL  YEAR  OF  THE  CONTRACT  AND  THE 

C  DATE  THE  MDR  WAS  RECEIVED  IS  TAKEN  INTO  CONSIDERATION. 

C  WITH  THE  SHORTER  TIME  CARRYING  THE  GREATER  WEIGHT. 

C  IN  ADDITION.  THE  NUMBER  OF  DAYS  TAKEN  TO  CLOSE  THE  MDR 

C  ARE  LISTtO. 

C 

C  THE  LOGIC  OF  THE  MAIN  PROGRAM  IS  AS  FOLLOWS: 

C 

C  FIRST,  IN  THE  SUBROUTINE  CALLED  ‘'REVIEW".  THE  RAW  DATA  IS  READ 
C  FROM  FILE  ONE,  SCREENED  FOR  ERRONEOUS  DATA  FIELDS 

C  AND  THEN  REWRITTEN  TO  FILE  TWO. 

C 

C  SECOND.  IN  "READER",  FILE  TWO  IS  READ  INTO  AN  ARRAY. 

C 

C  THIRD.  IN  " JDATER" ,  THE  LAST  THREE  DIGITS  OF  THE  JULIAN  DATE 
C  OF  THE  DATE  MDR  WAS  RECEIVED  IS  CONVERTED  INTO  MONTHS 

C  ONE  THROUGH  TWELVE. 

C 

C  FOURTH.  IN  "SORTER",  THE  MDRS  ARE  SORTED  ACCORDING  TO  FSCM 
C  AND  THE  YEAR  AND  MONTH  THE  MDRS  WERE  RECEIVED. 

C 

C  FIFTH.  IN  "WEIGHT".  THE  TIME  BETWEEN  THE  FISCAL  YEAR  OF  THE 
C  CONTRACT  AND  THE  DATE  THE  MDR  WAS  RECEIVED  IS 

C  COMPUTED  TO  REPRESENT  THE  AGE  OF  THE  MDR.  THE  AGE 

C  IS  USED  TO  WEIGHT  THE  MDR  (SEE  VARIABLE  DICTIONARY  FOR 

C  WEIGHTS  USED) 

C 

C  SIXTH.  IN  "WRITER".  THE  FSCM.  MONTH  AND  YEAR  THE  MDR  WAS  RECEIVED 
C  THE  WEIGHTED  AVERAGE  OF  NUMBERS  OF  MDRS  AND  THE  NUMBER  OF 

C  DAYS  REQUIRED  TO  CLOSE  THE  MDR  ARE  WRITTEN  TO  FILE  THREE. 


VARIABLE  DICTIONARY 


» '*jrv*******«*******»j«*j< 


THE  PROGRAM  VARIABLES  ARE  DEFINED  AS  FOLLOWS: 


AC 

DAYSCL 

DEF 

FAC 

FDAYS 

FDAYS1 

FDEF 

FIL1 

FIL2 

FILS 

FIL4 

FIL5 

FIL6 

FIL7 

FIL8 

FIL9 

FPRI 

FRCN 

FSCM 

FSCM1 

FY 


MEANING 

ACTION  CODE 
DAYS  TO  CLOSE 

DEFECT  CODE 

ACTION  CODE 

DAYS  TO  CLOSE 

DAYS  TO  CLOSE 

DEFECT  CODE 

FILLER  #1 

FILLER  M2 

FILLER  #3 

FILLER  #4 

FILLER  *5 

FILLER  #6 

FILLER  HI 

FILLER  *8 

FILLER  US 

PRIORITY  CODE 

RECORD  CONTROL  NUMBER 

MANUFACTURER  CODE 

MANUFACTURER  CODE 

FISCAL  YEAR 


REMARKS 

ONE  LETTER  CODE 
FOUR  INTEGER  NUMBER  OF  DAYS 
TAKEN  TO  CLOSE  OUT  MDR 
ONE  LETTER  CODE 


FILLERS  WERE  USED  TO  SIMPLIFY 
RECORD  MANIPULATIONS 


FIRST  LETTER  IS  'S'  IN  ALL  CASES 
IDENTIFIES  MANUFACTURER 

YEAR  OF  CONTRACT 
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01550004 
01560004 
01570004 
*01580004 
01590004 
01600004 
01610004 
01620004 
01630004 
01640004 
*01650004 
01660004 
*01670004 
01680004 
01690004 
01700004 
01710004 
01720004 
01730004 
01740004 
01750004 
01760004 
Cl  770004 
01780004 
01790004 
01800004 
01810004 
01820004 
01830004 
01840004 
01850004 
01860004 
01870004 
01880004 
01890004 
01900004 
01910004 
01920004 
01930004 
01940004 
01950004 
01960004 
01970004 
O 1 980004 
01990004 
02000004 
.02010004 
02020004 
02030004 
02040004 
*02050004 
02060004 
*02070004 
02080004 
02090004 
02100004 
02110004 
02120004 
02130004 
02140007 
02150004 
02160004 
02170004 
02180007 
02190007 
02200004 
02210004 
02220004 
02230004 
02240004 
02250004 
02260004 
02270004 
02280004 
02290004 
02300004 
02310004 
02320004 
02330004 
02340004 


oooooo  o  o  o  ^  ooooo 


C 

I  END 

END  SWITCH 

SET  TO  '1'  IN  REEDER 

c 

TO  PROPERLY  END  DATA  READ  IN 

C 

1  FY 

FISCAL  YEAR 

c 

ITEMP1 

TEMPORARY  STORAGE 

USED  IN  "SORTER" 

c 

ITEMP2 

TEMPORARY  STORAGE 

USED  IN  "SORTER" 

c 

ITEMP3 

TEMPORARY  STORAGE 

USED  IN  "SORTER" 

c 

ITEMP4 

TEMPORARY  STORAGE 

USED  IN  "SORTER" 

c 

ITEMP5 

TEMPORARY  STORAGE 

USED  IN  "SORTER" 

c 

ITEMP6 

TEMPORARY  STORAGE 

USED  IN  "SORTER" 

c 

UJ 

ARRAY  PARAMETER 

USED  IN  "WEIGHT"  TO  SET  ARRAY 

C 

PARAMETERS  IN  AGER 

c 

UM 

DO  LOOP  PARAMETER 

USED  IN  "SORTER" 

c 

KYR 

YEAR  MDR  RECEIVED 

c 

MDRCTR 

MDR  COUNTER 

THE  NUMBER  OF  VALID  MDR  RECORDS 

c 

MDRNUM 

NUMBER  OF  MDRS 

THE  NUMBER  OF  MDR  RECORDS  INPUT 

C 

MDRVAL 

NUMBER  OF  MDRS 

c 

M0 1 

MONTH  MDR  RECEIVED 

THREE  DIGIT  INTEGER 

c 

M02 

MONTH  MDR  RECEIVED 

TWO  DIGIT  CONVERTED  INTEGER 

c 

M03 

MONTH  MDR  RECEIVED 

THREE  CHARACTER  VARIABLE  USED 

c 

IN  "REVIEW"  TO  SCREEN  DATA 

c 

NN 

DO  LOOP  PARAMETER 

USED  IN  "SORTER" 

c 

PRI 

PRIORITY  CODE 

c 

RCN 

RECORD  CONTROL  NUMBER 

c 

SORKEY 

SORT  KEY 

c 

WT 

WEIGHT 

ARBITRARY  WEIGHT  ASSIGNER  IN 

c 

"WEIGHT"  FOR  AGE  OF  MDRS 

c 

WTDMDR 

WEIGHTED  NUMBER  OF  MDRS 

c 

YR 

YEAR  MDR  RECEIVED 

TWO  CHARACTER  VARIABLE  USED  IN 

c 

“REVIEW" 

c 

»*»«*»»»»** 

*•***»»»  •  #**»»•«****  **'t***»a,*******»K*>r****»***»*v»vr»]r»  *  » 

c 

INITIALIZATION  SECTION 

c 

c 

c 

PURPOSE 

:  TO  INITIALIZE.  DECLARE 

AND  DEFINE  PROGRAM  VARIABLES 

c 

CHARACTER  SORKE Y ( 5000 )  *  10, FSCM( 5000) *5 
CHARACTER* 1  RCN( 5000 ) . PRI ( 5000) , DEF ( 5000) . AC( 5000) 

INTEGER  KYR ( 50C0) , M0 1 ( 5000) . M02 ( 5000) . I FY( 5000) . DAYSCL ( 5000 ) 
REAL  WTDMDR(5000) 

COMMON  DA YSCL . I FY . KYR . M0 1 . M02 . WTDMDR 
COMMON  FSCM.RCN.PRI . AC , OEF , SORKE Y 
MDRNUM  *  10000 


MAIN  PROGRAM 


CALL  RE VI EW( MDRNUM, MDRVAL) 
CALL  READER(MDRVAL) 

CALL  JDATER(MDRVAL) 

CALL  SORTER(MDRVAL) 

CALL  WEIGHT(MDRVAL) 

CALL  WRITER(MDRVAL) 

STOP 

END 


SUBROUI INES 

«  *  *  4  ft  »  »  *  *  *  *  **  *  •  **##-*****’**#ir*jr****#***#JKjfcW*****#*»*****'#**#** 

SUBROUTINE  REVI EW( MDRNUM, MDRVAL ) 


PURPOSE:  TO  REVIEW  RECORD  FOR  ERRONEOUS  DATA  INPUT 

IF  THE  DATA  MEETS  THESE  CRITERIA  THE  RECORD  WILL 
WRITTEN  TO  FILE  NUMBER  2 

CHARACTER'S  FSCM1 
CHARACTER' 1  FRCN.FPRI .FAC.FDEF 
CHARACTER-2  YR.FY 
CHARACTER'3  M03 
CHARACTER-4  FDAYS1 
C 

MDRVAL =0 
IEND»0 

DO  20  1=1, MDRNUM 

IF  ( I  END . EO . 1 )  GOTO  25 

CALL  REEDER ( FSCM1 , M03 , FY , YR , FDAYS 1 .FRCN.FPRI .FAC.FDEF, I  END) 
C  »***  THAT  PRIORITY  CODE  DOES  NOT  =  5,  OR  ZERO 
I F ( ( f FPRI ,NE , '5' ) .AND. (FPRI .NE. '0' ) )  .AND. 

C  -*•-  THAT  PRIORITY  CODE  DOES  NOT  =  5,  BLANK  OR  ZERO 
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02350004 
02360004 
02370004 
02380004 
02390004 
02400004 
02410004 
02420004 
02430004 
02440004 
02450004 
02460004 
02470004 
02480004 
02490004 
02500004 
02510004 
02520004 
02530004 
02540004 
02550004 
02560004 
02570004 
02580004 
02590004 
02600004 
02S 10004 
02620C04 
02630004 
-*02640004 
02650004 
**02660004 
02670004 
02680004 
02690004 
02700004 
02710004 
02720004 
02730004 
02740004 
02750004 
02760005 
02.770004 
**02780004 
02790004 
**02800004 
02810004 
02820004 
02830004 
02840004 
02850004 
02860004 
02870004 
02880004 
02890004 
02900004 
02910004 
02920004 
02930004 
02940004 
02950004 
02960004 
02970004 
02980004 
02990004 
03000004 
03010004 
03020004 
03030004 
03040004 
03050004 
03060004 
03070004 
03080004 
03090004 
03100004 
03110004 
03121028 
03130028 
03130128 


C  IF ( ( ( FPRI .NE . ‘ 5 ' )  .AND.  (FPRI.NE.'  ')  .AND.  ( FPRI . NE . '0' ) )  .AND.  03131037 
C  *•»*  THAT  ACTION  CODE  IS  F  OR  2  03140005 

+  ( ( FAC . EQ. 'F ' )  .OR.  ( FAC . EO. ' 2 ' ) )  .AND.  03150037 

C  THAT  DEFECT  CODE  IS  A  THRU  M  OR  X  03160034 

+  ((FDEF.LT.'N')  .OR.  ( FDEF  .EO.  'X'))  -AND.  03170034 

C  THAI  CONTRACT  YEAR  IS  BETWEEN  FY75  AND  FY99  03180034 

*  ((FY.GE. '75' )  .AND.  ( FY . LE . ' 99 ' ) ) )  THEN  03190037 

MDRVAL=MDRVAL+ 1  03210004 

CALL  WRYTER(FSCM1.M03.FY.YR.FDAYS1.FRCN. FPRI. FAC. FDEF)  03220004 

ELSE  03230004 

GO  TO  20  03240004 

ENDIF  03250004 

20  CONTINUE  03260004 

25  RETURN  03270004 

END  03280004 

C  03290004 

<;**•**»*•«***  »»  03300004 

SUBROUTINE  REEDER(FSCM1 ,M03 . FY , YR . FDAYS 1 , FRCN. FPRI , FAC. FDEF . I  END)  03310004 
C**  03320004 

C  03330004 

C  PURPOSE:  INPUTS  A  RECORD  03340004 

C  03350004 

CHARACTER'3  F111.M03  03360004 

CIIARAC1  rR*5  ISCM1  03370004 

UIARAC1  ER*  1  F IL2  .  T  I L4  .  F  I L5.  F  I L6  .  FRCN,  FPRI  .  T AC  .  FDEF  03380004 

CHARACTER* 12  FIL3  03390004 

CHARACTER'2  YR.FY  03400004 

CHARACTER* 11  FIL7  03410004 

CHARACTER*4  FDAYS 1  03420004 

CHARACTER'26  FIL8  03430004 

CHARACTER* 14  FIL9  03440004 

C  03450004 

READ( 1 , 101 . END  = 1 1 )  F I L 1 . FSCM1 , F IL2 . FRCN. F IL3 . FPRI .  03460004 

+  FIL4. YR.M03.FIL5. FAC, FIL6, FDEF.  03470004 

+  FIL7.FDAYS1.FIL8.FY.FIL9  03480004 

C  03490004 

101  FORMAT (A3,A5.A1,A1,A12,A1,A1,A2,A3,A1,A1,A1,A1,A11,A4,A26,A2,A14)  03500004 
GO  TO  12  03510004 

11  I END= 1  03520004 

12  RETURN  03530004 

END  03540004 

C  03550004 

C . 03560004 

SUBROUTINE  WRYTER( FSCM1 , M03 . FY . YR . FDAYS  1 . FRCN, FPRI , FAC , FDEF  )  03570004 

C-**** . 03580004 

C  03590004 

C  PURPOSE:  TO  WRITE  OUTPUT  TO  FILE  NUMBER  2  03600004 

C  03610004 

CHARACTER'S  FSCM1  03620004 

CHARACTER* 2  YR.FY  03630004 

CHARACTER* 1  FIL2.FIL4.FIL5.FIL6, FRCN, FPRI, FAC, FDEF  03640004 

CHARACTER'S  M03  03650004 

CHARACTER*4  FDAYS 1  03660004 

WRITE(2, 102)  FSCM1 .FRCN, FPRI ,YR,M03, FAC, FDEF, FDAYS1 .  03670004 

+  FY , FSCM1 , YR ,M03  03680004 

102  FORMAT (A5,A1,A1,A2,A3,A1,A1,A4,A2,A5,A2,A3)  03690004 

RETURN  03700004 

END  03710004 

C  03720004 

C** a, *.»»**».»*«**»»««»»**»»«. »««**«. ..**«»»»«.»»».»».  03730004 

SUBROUTINE  READER(MDRVAL)  03740004 

c.„ »•.*.»*««».»»»»»»«»«.»*#»»*»»**»*»»»« *»«**«»»*»»»*•*»«*.«*»,*»-»-»  03750004 

C  03760004 

C  PURPOSE:  INPUTS  A  RECORD  FROM  FILE  NUMBER  2  03770004 

C  03780004 

CHARACTER  SORKEY( 5000) *  10, FSCM( 50001*5  03790004 

CHARACTER' 1  RCN( 5000) . PRI (5000) ,DEF { 5000) , AC( 5000)  03800004 

INTEGER  KYR( 5000), MO 1( 5000) ,M02( 5000), IF Y( 5000) ,DAYSCL( 5000)  03810004 

REAL  WT[>M0R( 50001  O3820004 

COMMON  DAYSCL , I FY ,KYR , MO  1 ,M02 , WTDMDR  03830004 

COMMON  FSCM.RCN.PRI . AC , DEF , SORKEY  03840004 

REWIND  2  03850004 

C  03860004 

DO  10  1=1 .MDRVAL  03870004 

100  READ(2, 1C2)  FSCM( I ) . RCN( I ) , PRI ( I ) ,  03880004 

+  KYR(I),M01(I),AC(I),DEF(I) , DAYSCL ( I ) ,  03890004 

+  IFY( I ) , SORKEY ( I )  03900004 

102  FORMAT (A5,A1,A1,I2,I3,A1,A1,I4,I2,A10)  03910004 

10  CONTINUE  03920004 

20  RETURN  03930004 


END 

C 

. . . . . . . 

SUBROUTINE  dDATER(MDRVAL ) 

C*  *'•••• 

C 

C  PURPOSE:  TO  CONVERT  JULIAN  OATES  INTO  MONTHS  1  -  12 
C 

CHARACTER  SORKEY ( SOOO )* 10. FSCM( 5000) *  5 
CHARACTER' 1  RCN(SOOO) ,PRI( 5000) , DEF (5000) ,AC(5000) 

INTEGER  KYR(SOOO) .M0 1(5000 ) .M02( 5000) .IF Y( 5000). DAYSCK 5000) 
REAL  WTDMDR(5000) 

COMMON  DA YSCL . I F Y . KYR , M0 1 . M02 . WTOMDR 
COMMON  FSCM.RCN.PRI . AC . DEF . SORKEY 
C 

DO  45  d= 1 .MORVAL 

1  I F ( ( M0 1 ( J ) . GE . 00 1 ) . AND . ( M0 1 ( J ) . LE . 03 1 ) )  THEN 
M02( J)  =  01 

ELSE  IF((M01(J).GE. 032 ) . AND . (M0 1 ( J) . LE .059 ) )  THEN 
M02 ( J )  «  02 

ELSE  IF((M01(J).GE. 060 ) . AND . ( M0 1 ( J ) . LE . 090 ) )  THEN 
M02 ( J )  =  03 

ELSE  1 F ( ( MO 1 ( 0 ) . GE . 09 1 ) . AND . (MO 1(d). LE. 120))  THEN 
M02 ( d )  =  04 

ELSE  IF((M01(d).GE.121). AND .(M01(d).LE.151))  THEN 
M02  ( d )  =  05 

ELSE  IF((M01(J).GE. 152 ) . AND . (M01 (d ) . LE . 18 1 ) )  THEN 
M02(d)  =  06 

ELSE  I F ( (M0 1 ( d ) .GE . 182 ) . AND . (MO  1(d). LE. 212))  THEN 
M02 ( d )  =  07 

ELSE  IF((M0l(d).GE,213). AND . (MC 1(d). LE. 243))  THEN 
M02 ( d )  «  08 

Ei.SE  IF((M01(J).GE.244).  AND  .  (MO  1(d),  LE.  273))  THEN 
M02( d)  =  09 

ELSE  IF((M01(J).GE.274). AND .(M01(d).LE.304))  THEN 
M02 ( d )  =  10 

ELSE  IF((M01(J).GE.  305 )  .  AND  . (M.0 1(d). LE. 334))  THEN 
M02 ( d )  *  11 

ELSE  IF ( (M01 ( d) . GE . 335) . AND . (M01 (d) . LE . 366 ) )  THEN 
M02  { d )  =  12 
ENDIF 

45  CONTINUE 
50  RETURN 
END 


SUBROUTINE  SORTER(MDRVAL ) 

C'*»»  •  •»>».«•  »»».»»»•*•»««  *m*m****M**wm 

c 

C  PURPOSE:  TO  PREPARE  FOR  LATER  MERGING  SORTING  IS  DONE 
C  BY  FSCM  BY  YEAR  MDR  RECEIVED  AND  BY  MONTH 

C 

CHARACTER* 10  ITEMPG 
CHARACTER'S  ITEMP1 

CHARACTER  SORKE Y ( 5000 ) *  10. FSCM(5000) ‘5 
CHARACTER* 1  RCN( 5000) , PR  I ( 5000 ), DEF ( 5000) ,AC( 5000) 

INUGER  KYR15000) .M0 1(5000 ) ,M02( 5000) , I FY ( 5000) , DAYSCLI 5000 ) 
REAL  WTDMDRI 5000) 

COMMON  DAYSCL. IFY.KYR.M01 .M02.WTDMDR 
COMMON  FSCM.RCN.PRI , AC. DEF .SORKEY 
NN=MDRVAL- 1 
DO  110  d= 1 , NN 
dM  =  MDRVAL-1 
C 

DO  120  1=1. JM 

IF  ( SORKEY ( I ) . LE . SORKEY ( 1  + 1 ) )  THEN 
GO  TO  120 

ELSE 

ITEM? 1  *  FSCM( I ) 

ITEMP2  =  KYR(I) 

ITEMP3  =  M02( I ) 

ITEMP4  =  DAYSCL(I ) 

ITEMP5  =  IFY(I) 

ITEMP6  =SORKE Y(  I ) 

FSCM(I)  =  FSCMU  +  1) 

KYR(I)  =  KYR( 1  +  1 ) 

M02 ( I  )  =  M02(I+1) 

DAYSCL(I)  =  DAYSCL( 1  +  1 ) 

IFY(I)  =  I FY(  1+  1 ) 


03940004 
03950004 
03960004 
03970004 
03980004 
03990004 
04000004 
04010004 
04020004 
04030004 
04040004 
04050004 
04060004 
04070004 
04080004 
04090004 
04100037 
04110004 
04120037 
04130004 
04140037 
04150004 
04160037 
04170004 
04180037 
04190004 
04200037 
04210004 
04220037 
04230004 
04240037 
04250004 
04260037 
04270004 
04280037 
04290004 
04300037 
043 10004 
04320037 
04330004 
04340004 
04350004 
04360004 
04370004 
04380004 
04390004 
04400004 
044 10004 
04420004 
04430004 
04440004 
04450004 
04460004 
04470004 
04480004 
04490004 
04500004 
04510004 
04520004 
04530004 
04540004 
04550004 
04560004 
04570004 
04580004 
04590004 
04600004 
04610004 
04620004 

**©owv/*t 

04640004 

04650004 

04660004 

04670004 

04680004 

04690004 

04700004 

04710004 

04720004 

04730004 
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SORKEY(I)  =  S0RKEY(I+1) 
FSCM(  1  +  1 )  =  ITEMP1 
KYR(I-M)  =  ITEMP2 
H02 ( 1 4 1 )  =  ITEMP3 
DAYSCL(I+1)  =  ITEMP4 
IFY(I+1)  =  ITEMP5 
SORK£Y( 1*1)  -ITEMP6 
END  IF 

120  CONTINUE 
1 10  CONTINUE 
RETURN 
END 


SUBROUTINE  WE  I GHT ( MDRVAL  ) 


PURPOSE:  TO  COMPUTE  A  WEIGHTED  AVERAGE  OF  MDRS  BY  MANUFACTURER 

BY  MONTH  MDR  WAS  RECEIVED 

INTEGER  MDRCTR(SOOO) 

CHARACTER  SORKEY( 5000) *  10, FSCM(  5000) *5 

CHARACTER  *  1  RCN( 5000 ) , PR I ( 5000 ) . DE  F ( 5000 ) , AC ( 5000 ) 

I NT  EGER  K YR ( 5000 ) , M0 1  ( 5000 ) . M02 ( 5000 ) . I F  Y ( 5000 ) , DA YSCd 5000 ) 
REAL  WTOMDR( 5000) 

COMMON  DAYSCL. I FY.KYR, M0 1 .M02, WTDMDR 
COMMON  FSCM.RCN.PRI . AC . OEF . SORKE Y 
M=0 

M  =  M  +  1 

IF  (M.EO.MDRVAL+1 )  GO  TO  55 
WTDMDR ( M ) =0 . 0 

CALL  SAME R( MDRVAL .MDRCTR . M) 

L=MDRCTR(M) 

DO  45  Nc  1  .  L 
JJ=M 

IF  (L  .EQ,  1)  GOTO  30 

J.J  =  M  +  N  -1 

IF  (N  .EQ.  1)  GOTO  30 

DAYSCL(M)  =  DAYSCL ( M )  +  DAYSCL(JJ) 

CALL  AGER(WT.JJ) 

WTOMDR(M)  =  WTDMDR(M)4-WT 
CONTINUE 

DAYSCL ( M )  =  DAYSCL (M)/MDRCTR(M) 

M=M+MDRCTR(M)-1 
GO  TO  25 
RETURN 
END 


#*tr«9**a<»)K*W)t*»»*»»*»*«w»**»j|(»n»-yrKK*******************.*******WK».*K** 

SUBROUTINE  SAMER( MDRVAL . MDRCTR . M) 


PURPOSE:  TO  CHECK  FOR  RECORDS  WITH  THE  SAME  FSCM. 

YEAR  ANO  MONTH  ANO  INCREMENT  A  COUNTER 
CALLED  MDRCTR  TO  TRACK  THE  NUMBER  OF  RECORDS 
WITH  THE  SAME  PARAMETERS.  THIS  TOTAL  WILL 
BE  USED  IN  WAITER  TO  COMPUTE  WEIGHTED  AVERAGES 

INTEGER  MDRCTR (5000) 

CHARACTER  SORKE Y ( 5000) *  10 , FSCM( 5000) *5 
CHARACTER’ 1  RCN( 5000) . PR I ( 5000) ,DEF( 5000) .AC ( 5000) 

INTEGER  KYR(5000) , M0 1(5000 ).M02( 5000) . I FY ( 5000) , DAYSCL ( 5000) 
REAL  WTDMDR ( 5000) 

COMMON  DAYSCL , I F Y . KYR . M0 1 . M02 , WTDMDR 
COMMON  FSCM.RCN.PRI .AC. DEF.SORKEY 


THIS  DO  LOOP  IS  LIMITED  TO  THE  NUMBER 

nc  iinnc  nc  a  aiiicm  cpru  tm  a  aahaitu 
CIWIV  ^  O  •  M  Ut  •  UI1  r  v/VI  l<«  M  I'lUH  I  I  I 

*  * ’NOTE**  THE  UPPER  LIMIT  OF  THE  LOOP  MAY  REQUIRE  MAINTENANCE 

MDRCTR(M)= 1 
DO  60  K= 1 , 100 

IF  ( ( FSCM(M) . EO . FSCM( M+K ) ) . AND .(KYR(M).EQ. KYR(M+K ) ) . AND . 

+  ( M02 ( M ) . EO . M02 ( M+K ) ) )  THEN 

MDRCTR(M)  =  MDRCTR (M)  +  1 
ELSE 

GO  TO  40 
END  IF 
60  CONTINUE 


04740004 

04750004 

04760004 

04770004 

04780004 

04790004 

04000004 

04810004 

04820004 

04830004 

04840004 

0485)004 

0486.004 

04870004 

04880004 

04890004 

04900004 

04910004 

04920004 

04930004 

04940004 

04950004 

04960004 

04970004 

04980004 

04990004 

05000004 

05010004 

05020004 

05030004 

05040004 

05050004 

05060004 

05070004 

05080007 

05090004 

05100004 

05110004 

05120004 

05130004 

05140004 

05150004 

05160004 

05170004 

05180004 

05190004 

05200004 

05210004 

05220004 

05230004 

05240004 

05250004 

05260004 

05270004 

05280004 

05290004 

05300004 

05310004 

05320004 

05330004 

05340004 

05350004 

05360004 

05370004 

05380004 

05390004 

05400004 

05410004 

AC  4 OAAA A 

05430004 

05440004 

05450004 

05460004 

05470004 

05480004 

05490004 

05500004 

05510004 

05520004 

05530004 
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40  RETURN 
END 
C 

£****jr**fc**«»»*******XX*»4r******»>***¥X*.********:**X****XW******«**M«*« 

SUBROUTINE  A6ER(WT , uJ ) 

£B»»»**.*****ir«x»*M«*K*x**«*»*x*w*x«x**xiKV***%**x**x»*wx».>«xx*»*v****** 

c 

C  PURPOSE:  TO  COMPUTE  AN  AGE  AND  CORRELATE  I T  TO  A  RESPECTIVE 
C  WEIGHT 

r 

INHGER  AGE 

CHARACTER  SORKEY ( 5000 )* 10. F SCM( 5000 ) *5 
CHARACTER* 1  RCN( 5000 ) . PR  I ( 5000) . DEF ( 5000 ) . AC( 5000) 

INTEGER  K YR ( 5000 ) , MO  1 ( 5000 ) , M02 ( 5000 ) . I F Y ( 5000 ) , 0 A Y SCL ( 5000 ) 
REAL  WTDMDR( 5000) 

COMMON  DAY SCL, IFY.KYR.M01 , M02 , WTDMDR 
COMMON  FSCM.RCN.PRI . AC, DEF .SORKEY 
WT  =0 

,VGE=KYR( JU)-  I FY( UJ )+  1 
IF  ((AGE.EO. l).0R,(AGE.E0.2))  WT  =  1.0 
IF  (AGE.EO. 3)  WT  =  .82 

IF  (AGE.EO. 4)  WT  =  .47 

IF  (AGE.EO. 5)  WT  =  .18 

55  RETURN 

END 
C 

£aMw»*K»*»»'»**XWK*X*XW*»*V***«*‘W***W**M*X********»***W*XW*»**«**V*«** 

SUBROUTINE  WRITER(MDRVAL) 

c 

C  PURPOSE:  TO  WRITE  OUTPUT  TO  FILE  NUMBER  3 

C 

C 

CHARACTER  SORKEY ( 5000)* 10. FSCM( 5000) *5 
CHARACTER* 1  RCN( 5000) . PRI ( 5000) , DEF ( 5000) , AC(LOOO) 

INTEGER  KYR( 5000) . MO  1 ( 5000) , M02 ( 5000) , IFY(5000) ,DAYSCL(5000) 
REAL  WTDMDR ( 5000) 

COMMON  DA YSCL . I F Y . KYR . M0 1 . M02 . WTDMDR 
COMMON  FSCM.RCN.PRI .AC. DEF, SORKEY 

C 

C  WRITE  THE  FIRST  RECORD 

WRITE (3. 190)  FSCM( 1 ) ,M02( 1 ) ,KYR( 1 ) ,WTDMDR( 1 ) ,DAYSCL( 1 ) 

C 

C  WRITER  THE  REST  OF  THE  FILE 

DO  192  I =2 .MDRVAL 

IF  ( ( FSCM( I ) . E0.FSCM( I- 1 ) ) .AND. (KYR( I ) . EQ.KYR( 1-1 ) ) 

*  . AND . (M02 ( I ) . EO. M02( I  -  1 ) ) )  THEN 

GO  TO  192 

ELSE 

WRITE ( 3 , 190)  FSCM( I ) , M02( I ) , KYR( I ) , WTDMDR ( I ) , DA YSCL ( I ) 

ENDIF 

1 90  FORMAT (A5 , 2X , 1 2 , 2X , 1 3 , 2X , F5 . 2 , 2X , 14 ) 

192  CONTINUE 
RETURN 
END 

/* 

//GO , FT01F001  DD  DSN=GOR . GROVER . ATL .MDRTEMP3 ,DISP=OLD 
//G0.FTO2FOO1  DD  DSN=GOR .GROVER . ATI  . MDRTEMP4 , 

//  DISP  =  (  .  'H  SS  )  . 

//*  DISP=(I, uW.CATLG, DELETE) , 

//  UNIT  =WORKD , SPACE  =  ( CYL , ( 1 , 10) .RLSE) , 

//  DCB=(RECFM=FB,LRECL=30.BLKSIZE=3000) . 

//  V0L=SER=W0RKW1 

//GO . FT03F001  DD  DSN=GOR .GROVER .MDR . INATL .MAY90, 

//  DISP=(NEW,CATLG, DELETE). 

//  UNIT  =WORKD , SPACE  =  ( TRK , ( 1 . 1 ) .RLSE) , 

//  V0L=SER=D0R0G2, 

//  DCB*(RECFM«FB.LRECL«27,BLKSIZE=2700) 

//GO  FTOCFOOI  DO  SY50UT** 

//SYSOUT  00  3YS0UI  =  * 

/  /r  IK'IIMPIIH'.  *>fa  CVCf” 

/  /  O  I  *>UIVVI*»F  uu  J  I  ouu  I  -  * 

//SYSPRINT  DD  SYSOUT=* 

/* 

// 


05540004 
05550004 
05560004 
05570004 
05580004 
05590004 
05600004 
05610004 
05620004 
05630004 
05640004 
05650004 
05660004 
05670004 
05680004 
05690004 
05700004 
057 10004 
05720004 
05730004 
05740004 
05750004 
05760004 
05770004 
05780004 
05790004 
05800004 
05810004 
05820004 
05830004 
05840004 
05850004 
05860004 
05870004 
05880004 
05890004 
05900004 
05910004 
05920004 
05930004 
05940004 
05950004 
05960004 
05970004 
05980004 
05990004 
06000004 
06010004 
06020004 
06030004 
06040004 
06050004 
06060004 
06070004 
06080004 
06090004 
06100035 
06110035 
06120029 
06130029 
06140004 
06150004 
06160022 
06170036 
06180007 
06190017 
06191034 
06200034 
06220004 
06230004 
06240004 
06250004 
06260004 
06270004 
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//G0R6O4OI  JOB  (6040, GOR) . 'GROVER ' , CLASS* t ,MSGCt-ASS=V 
//RUNFTN  EXEC  FORTVCG 

//FORT . SYS1N  OD  OSN=GOR .GROVER, 0UEST3(MERGPR0D) ,DISP=SHR 
//GO.FTOIFOOI  DO  DSN=GOR  .  GROVER  .NPP 1  .  LA .  SORT ,  DI  SP=Sl  R 
//GO  .  FT02F001  OD  DSN=GOR  .GROVER  .  FAC .  LA  .MAR90,0ISP  =  SH,: 

/ /GO . FT03F001  00  0SN=G0R .GROVER .MDR . I NLA .MAV90, DISP=SHR 
/ /GO , FT04F001  DO  DSN=GOR .GROVER , LA . INQUEST .MAY90, 

//  DISP= (NEW, CATLG .DELETE ) , DCB= (LR£CL=388 . RECFM=FB .BLKSI ZE-3080) , 
//  UNIT=WORKD , SPACE = (CYL . ( 5 , 10) , RUSE ) , V0L=SER=W0RKW1 

//*  UN1T=TAPE, LABELSEXPDT=93001 
//GO . FT06F001  OD  SYSOUT=’ 

/ /SY50U1  OD  SYSOUT  =  ♦ 

//SYtiUDUMP  DO  SYSOUT  =  ’ 

//SYSPRINT  DC  SYSOUT=* 

// 


00010060 
00030005 
0004006 1 
00044060 
00045062 
00046060 
00047060 
00048060 
00048160 
00049060 
00049129 
00049229 
00049329 
00049429 
00049529 
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C  THIS  MODULE  MERGES  THE  FACILTY  PROFILE.  THE  HISTORY  FILE  AND 
C  THE  MDR  FILE  BY  FSCM  TO  PRODUCE  A  MASTER  DATA  FILE  FOR  THE  MODEL. 
C 

C  THIS  IS  A  FILE  MERGER  USED  FOR  QUEST  III. MEMBER  FOR(MATCH7 ) 

C  THIS  IS  THE  PRODUCTION  VERSION  TO  BE  USED  WITH  THE  NEW  QAMIS. 

C  SPECIAL  PROCESSES  ARE  PICKED  UP  ON  FACILITY  PROFILE. 


00010033 

00020033 

00030033 

00040051 

00041052 

00050048 


C  ALSO,  GOVT  VERIFICATION  CODE  IS  PICKED  UP  TO  IDENTIFY  IQUE  FACI LITIES . 00051049 
C  00052049 

C  DECLARE  AND  ARRAY  VARIABLES  00060033 

C  ARRAYS  ARE  DIMENSIONED  TO  ACCEPT  NO  MORE  THAN  TEN  YEARS  OF  DATA  00070033 

C  00080033 

C  A  AND  AA  AND  AAA  ARE  FSCM  OR  CAGE  00090046 

C  B  AND  BB  ARE  YEAR  00100044 

C  C  AND  CC  ARE  MONTH  00110044 

C  00120044 

CHARACTER  A*5,AA(120)”5, DUM1 ( 120) * 10,DUM2( 120)*4,GVN( 120)*4  00130049 

CHARACTER  DUM3( 1 20 ) *34 1 . AOPER( 1 20) *2 . 0PER»2 . FLUF 1  *  10  00140052 

CHARACTER  FLUF2*16,FLUF3*12,FLUF4*111,AAA*5,SPEC*4,GV*4.FLUF5‘9  00150049 

INTEGER  BB( 120) ,CC( 120) . B . C , E , NQAR( 120) ,DAYSCL( 120) , ISPEC( 120)  00160048 

REAL  WMDR( 120)  00170037 

00180010 

»**  INITIALIZE  AND  SET  DEFAULT  VALUES  ***  00190010 

00200033 

IFSCM=0  00210010 

I YR=0  00220010 

IM0NTH=O  00230010 

NEXT  THREE  VARIABLES  ARE  USED  TO  SUPPRESS  FILE  READ  00240033 

ICTL  = 1  00250012 

JCTL=1  00260021 

KCTL=1  00270021 

AAA  = ' AAAAA '  00280031 

A= ' AAAAA '  00290041 

I  COUNT =0  00300020 

ISKIP-1  00310016 

DO  5  11=1 , 120  00320016 

AA( II ) ='00000'  00330016 

BB (II) =0  00340016 

CC(II)=0  00350016 

£  CONTINUE  00360016 

SET  DEFAULT  VALUES  00370034 

10  DO  20  I=1.i20  00380010 

NQAR(I)=0  00390012 

I SPEC( I ) =0  00391048 

GVN( I ) = '  '  00392049 

WMDR( I ) =0 . 0  00400035 

DAYSCL( I )=0  00410035 

A0PER( I ) = ' AB '  00420012 

20  CONTINUE  00430010 

INPP 1=1  00440010 

00450033 

■*>  INITIALIZATION  COMPLETE  ***  00460010 

00470010 

«»»  STEP  2  ***  00480010 

*«*  READ  NPP 1  FILE  RECORD  TO  BEGIN  MATCHING  PROCESS  ***  00490010 

00500033 

THE  HISTORY  TILC  IS  SKIPPED  IF  THE  FIRST  HISTORY  RECORD  FOR  A  FSCM  00510033 

HAS  ALREADY  BEEN  READ. SEE  'RESET  COUNTERS  AND  DEFAULT'  SECTION  00570033 

100  I F  (  I  SKI  P- 1 )  109,101,101  00530016 

101  READ< 1, 102,END=330)  DUM1 ( INPP1 ) ,AA( INPP1 ) , DUM2( INPP1 ) ,BB( INPP1 )  00540046 

1 , CC( INPP 1 ) , 0UM3( INPP  1 )  00550046 

102  FORMAT (A10,A5,A4,I2,I2,A341)  00560052 

I  SKI P= 1  00570016 


THE  HISTORY  FILE  IS  SKIPPED  IF  THE  FIRST  HISTORY  RECORD  FOR  A  FSCM  00510033 

HAS  ALREADY  BrEN  READ. SEE  'RESET  COUNTERS  AND  DEFAULT'  SECTION  00530033 

100  IF (ISKIP-1)  109,101,101  00530016 

101  READL 1 , 102 , END* 330)  DUM1 (INPP 1 ), AA( INPP 1 ), DUM2( INPP 1 ). BB( INPP 1 )  00540046 

1 , CC( INPP 1 ) , 0UM3( INPP  1 )  00550046 

102  FORMAT (A10,A5,A4,I2,I2,A341)  00560052 

I  SKIP3 1  00570016 

TIMING  CONVENTION  FOR  HISTORY  RECORDS  IS  UNPP1  IS  THE  CURRENT  RECORD00580033 
AND  KNPP1  IS  THE  PREVIOUS  RECORD.  INPP1  IS  THE  NEXT  RECORD  TO  READ.  00590033 
UNPP 1 = INPP 1  00600010 

KNPP1=INPP1-1  00610010 

INPP 1= INPP 1 + 1  00620010 

UPON  IDENTIFICATION  OF  A  FIRST  FSCM  RECORD,  ATTEMPT  TO  MERGE  WITH  00630033 
FACILTY  PROFILE  00640033 

I F ( UNPP 1  .EQ.  1)  GO  TO  110  00650021 

IF  CURRENT  AND  PREVIOUS  RECORDS  HAVE  DIFFERENT  FSCMS,  WRITE  PREVIOUS00660033 
FSCM  RECORDS  TO  TAPE. IF  THE  SAME  ATTEMPT  TO  MERGE  WITH  MDR  FILE.  00670033 
I F ( AA( JNPP 1 )  .GT.  AA(KNPPI))  GOTO  190  00680022 

I F ( AA ( UNPP 1 )  . EO.  AA(KNPPI))  THEN  00690012 

IF ( (AA( JNPP1 )  .GT.  A)  .OR.  ((AA(UNPPI)  ,EQ.  A)  .AND.  ( (BB( UNPP 1 >00700047 

1  .GT.  B)  .OR.  ((CC(UNPPI)  .GT.  C)  .AND.  (BB(JNPPI)  .EO.  B)))))  00710047 

2  GOTO  104  00720040 

IF ( ( AA( UNPP 1 )  . LT .  A)  .OR.  ((AA(UNPPI)  .EO.  A)  .AND.  ( (BB( UNPP 1 >00730047 

1  .LT.  B)  .OR.  ( ( CC( UNPP  1 )  .LT.  C)  .AND.  (BB(UNPPI)  .EO.  B)))))  00740047 


o  o  o  o  o  o  o  o  noon  o  o  o  non  oooooo 


2  GOTO  101 
GO  TO  240 
ELSE 

GO  TO  310 
ENDIF 
104  ICTL  = 1 

GO  TO  200 

***  STEP  3  *** 

*♦»  READ  FACILITY  PROFILE  FILE  »** 

109  INPP 1=2 

IF  END  OF  PROFILE  HAS  BEEN  REACHED  OR  HISTORY  LAGS  PREVIOUS  PROFILE 
SKIP  THIS  SECTION 

110  I F ( <JCTL  .EQ.  0)  GOTO  200 

IF ( AAA  .GT.  AA(UNPPI))  GOTO  200 

IF  HISTORY  MATCHES  PREVIOUS  PROFILE,  SKIP  THE  READ  AND  MERGE  RECORDS 
IF(AAA  .F.Q.  AA(UNPPI))  GOTO  130 

READ  A  NEW  PROFILE  RECORD.  IF  FSCM  MATCHES  HISTORY  FSCM,  MERGE 
RECORDS.  OTHERWISE  REPEAT  OR  GO  LOOK  AT  MDR  FILE 

READ( 2 , 120. END* 180)  TLUF 1 , AAA . FLUF2 , MQAR .OPER , FLUF3 . SPEC . FLUF4 . 
1GV.FLUF5 

120  FORMAT (A10.A5,A16,I2,A2,A12,A4,A111,A4,A9) 

IF  NO  MATCH  IS  FOUND,  DEFAULTS  VALUES  ARE  KEPT.  SEE  INITIALIZATION. 
IF  (AAA  .GT.  AA(UNPPI))  GOTO  200 
I F ( AAA  .EQ.  AA(JNPPI))  THEN 
GO  TO  130 
ELSE 

GO  TO  1 10 
ENDIF 

A  MATCH  HAS  BEEN  MADE.  APPEND  PROFILE  VARIABLES  TO  HISTORY  RECORD. 
130  DO  140  0=1. 120 
NQAR(d)=MQAR 
ACPER(U)=OPER 

I F( SPEC  .NE.  '  ')  ISPEC(U)=1 

GVN( 0 ) =GV 
140  CONTINUE 
GO  TO  200 

ONCE  END  OF  PROFILE  HAS  BEEN  REACHED.  OCTL  TURNS  OFF  FUTURE  READS 
180  UCTL=0 
GO  TO  200 

***  STEP  4  *** 

***  WRITE  RECORD  TO  TAPE** 

190  DO  192  L=1 .KNPP1 

WRITE(4, 191)  OUMI(L).AAU)  ,DUM2(L)  ,  BB  (  L )  ,  CC  ( L  )  ,  DUM3  ( L )  .  NQAR  (  L  ) 

1  , AOPER ( L ) . I SPEC( L ) , GVN( L) , WMDR (L) , DAYSCL ( L ) , L , KNPP 1 

191  FORMAT (A  10, A5. A4. 12. 12.A341 .I2.A2, 1 1.A4.F5.2, 14,213) 

I  COUNT  =  I  COUNT  f  1 

AA(L) ='00000' 

BB(L)=0 
CC( L )  =0 

192  CONTINUE 

***  RESET  COUNTERS  AND  DEFAULTS 
AA( 1 )=AA(dNPP1 ) 

BB( 1 ) =BB( JNPP 1 ) 

CC( 1 ) =CC( JNPP  1 ) 

DUM1 ( 1 )=DUM1(0NPP1 ) 

DUM2( 1 )=DUM2(0NPP1 ) 

DUM3( 1 )=DUM3( JNPP 1 ) 

JNPP 1=1 
1SKIP=0 
GO  TO  10 

***  END  OF  STEP  4  *»* 

***  MATCH  TO  MDR  FILE  BY  FSCM  AND  MONTH  AND  YEAR  *** 

***  STEP  5  »** 

READ  IS  SUPPRESSED  IF  THE  END  OF  MDR  FILE  HAS  BEEN  REACHED  OR 
HISTORY  FILE  LAGS  MDR  FILE 

200  IF(lCTL-l)  215.201,201 

201  I F (KCTL  .EQ.  0)  GOTO  101 

READ  MDR  RECORD.  PICK  UP  FSCM,  MONTH,  YEAR  .  MDR  COUNT  AND  DAYS 
READ(3,210,ERR=296, END =295)  A.C.B.D.E 
2 10  FORMAT ( A5 , 2X , 1 2 , 2X , 1 3 . 2X , F 5 . 2 , 2X , 1 4 ) 

215  I F ( A  .GT.  AA(dNPPI))  GOTO  270 
I  F(  A  .EQ.  AA(ONPPD)  THEN 
GO  TO  220 
ELSE 


00750040 
00760040 
00770012 
00780012 
00790012 
0080002 1 
00810021 
00820033 
00830033 
00840033 
00850033 
00860016 
00870033 
00880033 
0089002 1 
0090002 1 
00910033 
0092002 1 
00930033 
00940033 
00950049 
00951049 
00960049 
00970033 
0098002 1 
00990012 
01000012 
01010012 
01020012 
01030012 
01040033 
01050010 
01060012 
01070012 
01071048 
01072049 
01080010 
01090028 
01 100033 
01110030 
01120023 
01130033 
01140033 
01150033 
01160033 
01170010 
01180012 
01190049 
01200052 
01210016 
01220016 
01230016 
01240016 
01250010 
01260010 
01270016 
01280016 
01290016 
01300016 
01310016 
01320016 
01330010 
01340016 
01350010 
01360033 
61370010 
01380033 
01390033 
0  1 400033 
01410033 
01420033 
01430012 
01440021 
01450046 
01460046 
01470035 
61480016 
01490016 
01500012 
01510012 
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ICTL'1  01520038 

GO  TO  201  01530016 

ENDIF  .  01540012 

220  Ir(B-BB(UNPP1 ) )  201,230,280  01550046 

230  IF ( C-CC(UNPP 1 ) )  201,240,290  01560^46 

C  A  MATCH  HAS  BEEN  MADE.  APPEND  MDR  COUNT  TO  HISTORY  RECORD  01570033 

240  WMDR( JNPP1 )=D  01580016 

DA YSCL ( <JNPP 1 )  =  E  01590035 

ICTL  = 1  01600012 

GO  TO  101  01610016 

C  THE  HISTORY  FILE  LAGS  THE  MDR  FILE.  GO  BACK  AND  READ  ANOTHER  01620033 

C  HISTORY  RECORD. MDR  COUNT  OF  CURRENT  HISTORY  DEFAULTS  TO  2ER0  01630033 

270  IFSCM= IFSCM+ 1  01640010 

ICTL=0  01650012 

GO  TO  101  01660016 

280  I YR= I YR+ 1  01670010 

ICTL'O  01680021 

GO  TO  101  01690016 

290  IMONTH= IMONTH+ 1  01700010 

ICTL'O  01710021 

GO  TO  101  01720016 

295  KCTL=0  01730023 

GO  TO  101  01740021 

296  GO  TO  200  01750025 

***  END  OF  STEP  5  **»  01760033 

01770010 

***  END  PROGRAM  »*'  01780010 

310  WRITE(6.320)  AA ( KNPP 1 ) , AA ( JNPP 1 )  01790019 

320  F0RMAT(5X, 'NPP1  FILE  NOT  SORTED  BY  FSCM  IN  ASCENDING  ORDER  '.A5,  01800010 

15X.A5)  01810010 

GO  TO  190  01820036 

330  KNPP 1  =  UNPP 1  01830021 

DO  331  N= 1 , UNPP 1  01840021 

WRITE (4. 332)  DUM1 ( N) , AA ( N ) . DUM2 ( N ) , BB(N ) , CC( N ) , DUM3(N) , NOAR ( N )  01850012 

1  , AOPER(N) , ISPEC(N) ,GVN(N) ,WMDR(N) ,DAYSCL(N) .N.KNPP1  01860049 

332  FORMAT  1 A10.A5, A4 . 12, 12.A341 . 12.A2, 1 1.A4.F5. 2, 14,213)  01870052 

IC0UNT=IC0UNT+ 1  01880016 

331  CONTINUE  01890011 

WRI TE ( 6 . 333 )  I FSCM, IYR , IMONTH, ICOUNT  01900016 

333  FORMAT ( 5X , 41 10)  01910016 

335  STOP  01920017 

END  01930000 
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//G0R6040S  dOB  (6040. GOR ). 'GROVER ' .CLASS* 1 . MSGCLASS^V 
//RUNFTN  EXEC  FORTVCG. FVR£GN=2500K ,G0REGN=2O0GK 
//  P  ARM.  GO 11 '  LET , NORES . EP=MA IN, SIZE =500000' 

//TORT. SYSIN  00  DSN=GOR. GROVER. QUEST3(03PR0D).DISP=SHR 
//GO .FT01F001  DD  DSN=GOR . GROVER . LA . INQUEST .MAY90. DISP=SHR 
//GO . FT02F001  DD  DSN=60R . GROVER . LA . MAY90 .  DI SKZX ,UNIT=W0RKD , 
//  D I SP=( NEW, CATLG. DELETE  ) . 

//*  DISP=(NEW. CATLG. DELETE) , V0L=SER=W0RKW2 , 

//  DCB=(LRECL=235.RECFM=FB.BLKSIZE=2350) . 

//  SPACE=(CYL.(19,9).RLSE) 

//GO . FT03F001  DD  DSN=G0R , GROVER . QUEST3( PGMCTL ), DISP=SHR 
//GO . FT04F001  DD  DSN=GOR . GROVER .LALBL.ZX.UNIT  =WORKD . 

//  DISP=(NEW. CATLG, DELETE)  , 

//•  DISP=(NEW. CATLG. DELETE) , V0L=SER*W0RKW2 . 

//  DCB=(LRECL=236,RECFM=FB,BLKSIZE=2360). 

//  SPACE =(CYL , (9.9) .RLSE) 

//GO . FT09F001  DD  DSN=GOR .GROVER . LA . TOPZX . UNIT=W0RKD . 

//  DISP=(NEW. CATLG. DELETE), 

//*  DISP  = (NEW. CATLG. DELETE ) , V0L=SEfi=W0RKW2 . 

//  DCB=(LRECL= 172. RECFM=FB , BLKSI ZE= 17200) . 

//  SPACE=(CYL, < 3. 1 ) .RLSE) 

//GO . FT  I 1F001  DD  DSN=GOR  GROVER, LA  OUTZX .UNIT -WORKD . 


//  DI SP*  ( NI.W.CA  I  LG.Dt  l ETC  )  . 

//♦  D1SP-(NEW.CAILG. DELETE ) . VOL =SER=W0RKW2 . 

//  OCB=(LRECL= 156. RECFM-FB , BLKSI ZE  = 15600 ) . 

//  SPACE=(CYL, (2.1), RLSE) 

//GO  FT08F001  DO  DSN-GOR .GROVER .ALERT . 0MAR90.DI SP=SHR 
//GO . FT 10F001  DD  DSN=GOR .GROVER .MASTER . JUL90, DI SP=SHR 
//GO . FT06F001  DD  SYSOUT=» 

//SYSOUT  DD  SYSOUT  =  * 

//SYSUDUMP  DD  SYSOUT=* 

//SYSPRINT  DD  SYSOUT=* 

//* 

//STEP2  EXEC  FORTVCG , FVREGNC2500K , GOREGN=2000K , 

//  PARM.GO= 'LET, NORES. EP=MAIN,SIZE=500000' 

//FORT . SYSIN  DD  DSN=GOR . GROVER . QUESTS (ADDNAME ). DI SP=SHR 
//GO.FTOIFOOI  DD  DSN=GOR . GROVER . LA . OUTZX , DISP=SHR 
/ / GO . FT02F001  DD  DSN=GOR . GROVER . FSCM . ALL . DI SP=SHR 
/ /GO . FT03F001  DD  DSN=GOR . GROVER . LA . PRESORT . ZX ,UNIT=WORKD . 


OISP  = (NEW. CATLG, DELETE). 

DCB=(LRECL=  178,  RECFM=FB , BLKSI ZE=  17800). 
SPACE=(CYL, (3,1), RLSE) 

*  THIS  PROGRAM  WILL  SORT  ON  DATE  AND  QAORG  CODE 

*  AND  TYPE  AND  EFFECTIVENESS. 

*«»V*»»«»*«*»**»*»»»»»**»#»#tt»Y**»*4'*»'k.********»*«»» 


THIS  SEGMENT  SORTS  GOR .GROVER . LA . PRESORT . ZX  * 

■  ■I***#*  *#KV«''**>*]****>k***'****»***,*******‘**>*«**** 


// 

// 

// 

//* 

//* 

//* 

//’ 

//* 

//* 

//‘ 

//* 

//* 

//* 

//‘ 

//STEP2  EXEC  PGM=IERRCOOO,PARM='MSG=AP' , REGI0N=2000K 
//SORTLIB  DD  DSN=SYS1 .S0RTL1B,DISP=SHR 
//SYSOUT  DD  SYSOUT11* 

//SYSPRINT  DD  SYSOUT=* 

//SORTIN  DD  DSN=GOR. GROVER. LA. PRESORT. ZX,DISP=SHR 
//* 

//SORTOUT  DD  DSN=GOR . GROVER . LA . REPZX , DI SP= ( NEW , CATLG , DELETE ) , 

//  SPACE* (CYL, ( 1 , 1 ) ,RLSE),UNIT=WORKD, V0L=SER=W0RKW2 

//SORTWKOI  DD  UNIT=WORKD, SPACE=(CYL, 10) 

//S0RTWK02  DD  UNIT=WORKD . SPACE=(CYL , 10) 

/ /S0RTWK03  DD  UNIT=WORKD, SPACE=(CYL, 10) 

//S0RTWK04  DD  UNIT=WORKD , SPACE=(CYL . 10) 

//S0RTWK05  DD  UNIT=WORKD, SPACE=(CYL, 10) 

//SYSIN  DD  * 

SORT  FI  ELOS=( 20, 3 , CH, A , 17 . 3 ,CH, A . 1 , 3.CH, A, 10. 1 .CH.D , 1 10. 7 ,CH, A) 

END 


// 


00010099 
00020099 
00021099 
00040099 
00050099 
00062099 
00063099 
00063199 
00064099 
00065099 
00070099 
00081099 
00082099 
00082199 
00083099 
00084099 
00085099 
00086099 
00086199 
00087099 
00088099 
00089099 
00089199 
00089299 
OOOB9399 
00089499 
00089599 
00089699 
0032C099 
00330099 
00340099 
00350099 
00360099 
00360199 
00360299 
00361099 
00362099 
00363099 
00364099 
00365099 
00366099 
00367099 
00370099 
00380099 
00390099 
00400099 
004 10099 
00420099 
00430099 
00440099 
00450099 
00460099 
00470099 
00480099 
00490099 
00500099 
00510099 
00520099 
00530099 
00540099 
00550099 
00560099 
00570099 
00580099 
00590099 
00600099 
00610099 
00620099 
00630099 
00640099 
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***  THIS  PROGRAM  IS  THE  FIELDED  VERSION  FOR  QUEST  III 

*•*  THIS  PROGRAM  USES  THE  OCMC  DATA  STRUCTURE,  NOT  THE  DASC . 

***  MEMBER  03PR0D  IS  THE  FIELDED  VERSION. 

HAS  A  FIVE  CHARACTER  QAR  CODE 

’•"THIS  MODULE  IS  RUN  AFTER  A  MASTER  TAPE  HAS  BEEN  CREATED 
BY  MERGING  THE  MIS  WITH  THE  MDR  AND  FACILITY  PROFILE.'** 


DECLARE  AND  ARRAY  VARIABLES 


00010099 
00020099 
00030099 
00040098 
00050099 
00060022 
00070002 
00080002 
00090002 
00100002 
001 10002 
00120002 
00130002 
00140002 
00150082 
00160099 
00170002 
00180002 


CHARACTER  DCASR< 120) '6 . 0A0RG( 120) * 3 , FSCM( 120)'6,TYP(  120)'1 .  00130002 

1CMDTY( 120) *  2 . PVN( 120) *  1 . ADCASR'6 . BFSCMt 2000) *5 ,OPER( 120)*2.  00140002 

2FLAG( 120)* 18,DLRIN( 120) *  12 ,DLROUT( 120)* 12,DLR0H( 120)' 12,  00150082 

3GVN( 120)'4,0AR( 120)*5  00160099 

INTEGER  MONTH) 120) . YEAR1 <20) , PLANHR( 120) ,LOTINS( 120) ,PVIHR( 120) .  00170002 

1 PEHR ( 120) ,PRHR( 120) , AODR{ 120) ,BQDR( 120) ,CODR( 120) ,DQDR( 120) .  00180002 

2EQDR1 120) ,ODRHR( 120),TVLHR( 120) ,TNGHR( 120) ,FMSHR( 120) ,AOMNHR( 1 20 ) . 00 1 90002 
3SHI PMT ( 120) ,WD( 120) ,WDHR( 120) . INTHR( 120) ,REINHR( 120) .VISIT) 120) .  00200002 

4MRBHR ( 1 20 ) , ECP ( 1 20 ) . ECPHR (120), MDRHR ( 1 20) , MTGHR ( 120 ) . MRB ( 1 20 ) .  00210002 

5P0HR ( 120) ,PCO( 120) ,CAO( 120) .CONTR) 120) .DEGREE) 120) .  00220099 

6ACNTRT ( 120) .BCNTRT) 120) .OCNTRT) 120) .ISTRAT) 120) .ONHAND) 120) .  00230026 

70ALIIN) 120) .QALIRE) 120) . AONHND) 120) .BONHND) 120) .OONHND) 120) .  00240002 

8NQDR ( 120) .PVINP) 120) .PEELNP) 120) .NOAR) 120) , IPRNT) 120) .  00250099 

9ISE0) 120) .RECS) 120) .DAYSCL) 120) . STARTM, STARTY , ENDMO . ENDYR  00260002 

INTEGER  IPEER) 120) . I  SPEC) 120) . AVLHR) 120) , PA) 120) .CAR) 120)  00270099 

REAL  SI ( 120) ,EPA( 120) .DEVN) 120) .TOPCA) 120) .CARATE) 120) .  00280099 

1WDRATE I  120) .ECPRAT) 120) .AMRBRA) 120) , EPARAT ( 120) .DEVNRA) 120) .  00290099 

2WMDRRA ( 120) .TOPEPA) 120) .TOPMRB) 120) .TOPWD) 120) .TOPDEV) 120) .  00300099 

3T0PECP) 120) ,WMDR( 120) .TOPMDR) 120) , A (999 ,38 ) . AIDEAL) 4 , 7 ) .  00310052 

4 AWORST (4,7) ,BIDEAL(4.7) . BWORST ( 4 , 7 ) , WE  I GHT ( 7 ) , TOPSCR ( 1 4 , 1 20 )  00320099 

COMMON  /RVAR/A  00330002 

COMMON  /CHT7/BFSCM, FLAG  00340002 


'"THIS  MODULE  SELECTS  RELEVANT  DATA  RECORDS  FROM  THE  INPUT  FILE. 
PERFORMS  EDIT  CHECKS  AND  WRITES  THE  RECORD  TO  A  DISK  FILE.*** 

'•'STEP  1  '" 

•"INITIALIZE  PARAMETERS 


00210002 

00220099 

00230026 

00240002 

00250099 

00260002 

00270099 

00280099 

00290099 

00300099 

00310052 

00320099 

00330002 

00340002 

00350002 

00360002 

00370002 

00380002 

00390002 

00400002 

00410002 

00420002 

00430002 

00440002 

00450002 

004G0002 


ST  ARTM*99  00420002 

STARTY=99  00430002 

ENDM0r99  00440002 

ENDYR=99  00450002 

MONTHS* 12  00460002 

"'EACH  DCASR  CODE  SHOULD  BE  INSERTED  NEXT;  CREATING  A  UNIQUE  PGM  00470002 
"'OMIT  NEXT  LINE  FOR  OLA-WIDE  MODEL****  00480002 

AOCASR* ' S 1 102A '  00490002 

LCOUNT  =0  00500002 

NC0UNT=0  00510002 

KCOUNT-O  00520002 

UERR0R=0  00530002 

00540002 

"'ENTER  TIME  FRAME  LIMITS  **'  00550002 

AN  EXTERNAL  FILE  MUST  BE  SET  UP  TO  CONTAIN  DATES  TO  CONTROL  MODEL  00560002 
STARTM  AND  STARTY  ARE  THE  MONTH  AND  YEAR  TO  BEGIN  MEASURING  OA  EFF00570002 
ENDMO  AND  ENDYR  ARE  THE  MONTH  AND  YEAR  THE  MODEL  STOPS  00580002 

MONTHS  ARE  THE  MINIMUM  NUMBER  OF  DATA  POINTS  OF  HISTORY  NEEDED  00590002 
CUTYR  DELETES  ALL  DATA  PRIOR  TO  CY  SPECIFIED  00600002 

LONG  INDICATES  WHETHER  OR  NOT  BACKUP  FILES  ARE  CREATED.  00610002 

ICIP  SPECIFIES  WHETHER  OR  NOT  ALERT  FILE  IS  USED.  00620002 

00630002 

READ) 3 , 10)  STARTM, STARTY  00640002 

PERFORM  EDIT  CHECKS  ON  DATES  ENTERED  00650002 

CALL  TIMCHK) STARTM, STARTY, UERROR)  00660002 

IF) UERROR  . EO .  1)  GOTO  30  00670002 

READ) 3,10)  ENDMO, ENDYR  00680002 

DERFQRM  EDIT  CHECKS  ON  DATES  ENTERED  00690002 

IF (STARTY  .GT,  ENDYR)  GOTO  30  00700002 

CALL  TIMCHK(ENDMO, ENDYR. UERROR)  00710002 

IF (UERROR. EO. 1)  GOTO  30  00720002 

READ) 3,10)  MONTHS, ICUTYR  00730002 

IF (MONTHS  .LT.  3)  GOTO  20  00740002 

IF (MONTHS  .GT.  99)  GOTO  20  00750002 

READ(3 ,11)  ICIP, LONG  00760016 

WRITE(6 , 16 )  STARTM, STARTY, ENDMO, ENDYR  00770002 

GO  TO  100  00780002 

10  FORMAT (212)  00790002 
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11  FORMAT (211) 

16  FORMAT( IX. ' INPUT  ACCEPTED  NORMALLY.  NO  DEFAULTS.  START ' . 21 3 . 2X . 

1 'END' ,213) 

20  WRITE (6. 25)  MONTHS 

25  FORMAT( IX, 'HISTORY  OUTSIDE  ALLOWABLE  RANGE', 12) 

GO  TO  202 

30  WRITE(6 , 35)  ST A RTM, ST ARTY , ENDMO , ENDYR 
35  FORMAT( IX. 'DATES  NOT  ACCEPTED,  TRY  AGAIN'. 414) 

GO  TO  202 

**»  STEP  2**»* 

***READ  A  RECORD  FROM  MERGED  DATA  FILE  PRODUCTION  VERSION*** 
♦•’CHECK  FOR  MISSING  OR  INVALID  DATA  *** 

♦••DELETE  RECORDS  WITH  NO  HOURS  REPORTED  *** 

100  DO  195  1=1 , 120 

IPRNT ( I )=0 

READ( 1.101, END=202)  DCASR( I ) , QAQRG( I ) , FSCM( I ) ,TYP( I ) , 

1CMDTY( I ) ,PVN( I ) , YEAR( I ) ,MONTH( I ) , PLANHR( I ) . LOTINS( I ) . 

2PVIHR( I ) ,PEHR( I ) ,PRHR( I ) , AQDR( I ) , BQDR( I ) . CQDR( I ) ,DQDR( I  ) . 

3E0DR( I ) ,QDRHR( I ) . TVLHR( I ) , TNGHR( I ) , FMSHR( I ) , ADMNHR( I ) , SHIPMT( I ) , 
4W0( 1 ) . WDHR1  I ). INTHRt I ) . RE !NHR< I ) . VI S I T( I ) .MRBHRI I ) , ECP( I ) , ECPHR( I 
Q.MDRHRI I ).MTGHR( I ) ,MRB( I ) ,POHR( I ) . PCO( I ) ,CAO( I ) . AVLHR( I ) . SI ( I ) . 
6C0NTR1 1 1.DLR1N1 I ) ,DLROUT( 1 ) , ACNTRT ( I ) ,BCNTRT( I ) . 

70CNTRT ( I ) ,OALIIN( I ) , OALIRE { I ) , AONHND ( I ) , BONHND ( I ) , OONHND( I ) , 
8DLR0H( I ) ,NQDR( 1 ) , PVINP( I ) . PEELNP( I ) , OAR( I ) . PA( I ) , CAR( I ) , DEVN( I ) , 
9N0AR( I).OPER(I).ISPEC(I), GVN( I ) , WMDR( I ) , DAYSCL( I ) , ISEO( I  ) . RECS( I  ) 

101  FORMAT! A6. A3, A6, A1 ,A2. A  1.21 2,214, 14X.2I4.3X. 14, 13,212.211, 

1314, 14X. 314, 12. 14,213. 12, 14, 13, 214, 2X, 14 . 3X . 14, 13,212. 15, 5X . 
2F5.2, 15X,I6,6X,2A12,5I6,4X.3I6.A12,  I2,7X,2I5.5>:.A5.2X,I6,2X.  I4.2X 
3F4.0,29X,I2,A2.I1,A4,F5.2.I4,2I3) 

EPA( I )  =  (FLOAT  (CAR(I ))/( FLOAT ( PA ( I ) )+. 0001 ))* 100.0 
IF(EPA(I)  .GT.  100.0)  EPA(I)  =100.0 
KCOUNT =KCOUNT  + 1 
ISTRAT( I )=0 

DELETE  NEXT  LINE  FROM  OLA-WIDE  MODEL 
IF(DCASR(I)  .NE.  ADCASR)  GOTO  190 
IF(QAORG(I)  -EO.  '  ')  GOTO  190 

IF(FSCM(I)  .EO.  '  ')  GOTO  190 

I F ( (TYP( I )  .NE.  'N')  .AND.  (TYP(I)  ,NE .  'R'))  GOTO  190 
IF ( CMDTY ( I )  .GT.  'ZZ')  GOTO  190 
IF(CMDTY(I)  .EO.  'Y1')  GOTO  190 

I F ( ( PVN( I )  .NE.  'A')  .AND.  (PVN(I)  ,NE .  'B')  .AND.  (PVN(I)  .NE. 


IF(OAORG(I)  .EO.  '  ')  GOTO  190 

IF(FSCMd)  . EO.  '  ')  GOTO  190 

I F ( (TYP( I )  .NE.  'N')  .AND.  (TYP(I)  .NE.  'R'))  GOTO  190 
IF(CMDTY(I)  .GT.  'ZZ')  GOTO  190 
IF(CMDTY(I)  .EO.  'Y1')  GOTO  190 

I F ( ( PVN( I )  .NE.  'A')  .AND.  (PVN(I)  .NE.  'B')  .AND.  (PVN(I)  .NE. 
1  'C'  ) )  GOTO  190 

IF(RECS(I)  .LT.  MONTHS)  GOTO  190 
IF ( YEAR( I )  .GT.  ENDYR)  GOTO  190 

I F ( ( YEAR( I )  .EO.  ENDYR)  .AND.  (MONTH(I)  .GT.  ENDMO))  GOTO  190 
IF  (YEAfi(I)  .LT.  ICUTYR )  GOTO  190 

ITOTHR=PLANHR( I )+PVIHR(I )+PEHR(I )+PRHR( I )+QDRHR( I )+TVLHR( I )+ 
1TNGHR( I )+FMSHR( I )+AOMNHR(I )+WDHR( I )+INTHR( I )+REINHR( I )+MRBHR( I )+ 
2ECPHR(I )+MDRHR( I )+MTGHR(I )+POHR(I ) 

I F ( ( AVLHR ( I )  .LE.  2)  .AND.  (WMDR(I)  . EQ.  0.0))  GOTO  190 
JTOTHR=PVI HR ( I )+PEHR( I )+PRHR( I )+ODRHR( I )+FMSHR(I )+WDHR(I )+ 

1 1NTHR(I )+RE INHR ( I )+MRBHR( I )+ECPHR(I )+MDRHR( I )+POHR( I )+PLANHR( I ) 

I F( ( ITOTHR  . LC .  0)  .AND.  (WMDR(I)  .EO.  0.0))  GOTO  190 
I F ( UTOTHR  . EO .  0)  IPRNT (I )= 1 

CHECK  TO  SEE  IF  FACILITY  IS  STILL  UNDER  COAP  POLICY. 

IF  IT  IS,  REINTERPRET  DATA  .THIS  IS  ONLY  NEEDED  DURING  TRANSITION. 

I F ( (GVN( I ) ( 1 : 1 )  .NE.  'E')  .OR.  (GVN(I)(2:2)  .NE.  'E')  .OR. 

1 (GVN( I ) (3 : 3 )  .NE.  'E')  .OR.  (GVN(I)(4:4)  .HE.  'E'))  THEN 
DEVN(I )=  REAL(WD(I) )* .40 
WD(I)=(WD(I)*3)/5 
ENDIF 

IF  RECORD  SURVIVES  EDIT  CHECK,  ASSIGN  A  STRAT  ID  NUMBER 
LCOUNT=LCOUNT  +  1 

CALL  STRAT (I ,TYP, CMDTY, PVN.OPER , NOAR , I STRAT. I SEO.RECS, AVLHR) 
FURTHER  BREAKOUT  RESIDENT  FACILITIES  10  THE  SECOND  COMMODITY  ALPHA. 
BREAKOUT  MAINTENANCE  FACILITIES  TO  THE  FIRST  COMMODITY  ALPHA. 

CALL  PEERGP(I , ISTRAT , IPEER .CMDTY , PVN, NOAR ) 

WRITE  NEW  RECORD  TO  DISK  FOR  FURTHER  USE 

WRITE ( 2 . 150)  DCASR ( I ) ,OAORG( I ) , FSCM(I ) ,TYP( I ) ,CMDTY(I ) . PVN( I ) . 
1M0NTH( I ) . YEAR( I ) ,PLANHR( I ) . LOTINS{  I ) ,PVIHR( I ) , 

2PEHR( I ) , AQDR( I ) ,BODR( I ) ,CQDR( I ) ,DODR( I ) , EQDR(I ) , 

3ADMNHR( I ) , SHIPMT (I ) , WD(I ) , INTHR( I ) , REINHR( I ) . VI  SIT ( I  )  . 

4ECP( I ) , MTGHR( I ) ,MRB( I ) , PCO( I ) ,CAO(  I ) , SI ( I ) , EPA( I ) , DEVN( I ) , 

5C0NTR( I ) , DLRIN(I ) , DLROUT (I ) , ACNTRT ( I ) , BCNTRT (I ) . OCNTRT ( I ) , OALI IN 
6(1 ) .OALIRE ( I ) , AONHND( I ) , BONHND ( I ) ,OONHND(I ) , DLROH( I ) ,N0DR( I ) , 
7PVINP(I),PEELNP(I) ,OAR( I ) ,NQAR( I ) ,OPER(I ) ,WMDR( I ) , 


00800002 
00810002 
00820002 
00830002 
00840002 
00850002 
00860002 
00870002 
00880002 
00890002 
00900002 
00910099 
00920002 
00930022 
00940002 
00950002 
00960042 
00970002 
00980034 
00990002 
01000002 
)01010091 
01020099 
01030099 
01040002 
01050099 
01060099 
01070099 
01080099 
,01090099 
01 100099 
01 1 10099 
01 120099 
Ol 130002 
01140002 
01150002 
01 160002 
01170002 
01 180C02 
01 190002 
01200002 
01210099 
01220002 
01230002 
01240002 
01250002 
01260002 
01270002 
01280042 
01290042 
01300042 
01310099 
01320099 
01330099 
01340099 
01350099 
01360099 
01370099 
01380099 
01390099 
014000SS 
01410099 
01420099 
01430099 
01440099 
01450042 
01460002 
01470099 
01480047 
01490068 
01500047 
01510002 
01520099 
01530099 
01540091 
01550091 
01560099 
01570002 
01580002 
01590099 


ooo  ooo  o  o  ooooooooooooooooo  ooo 


8DAYSCL  ( I ) ,  r.SEO(  I ) .  RECS(  I ) .  ISTRAT(  I  )  ,  IPEER(  I ) ,  IPRNT(  1 )  01600048 

150  FORMAT ( A6 , A3, A6.A1.A2.A1, 212,414, 13,212, 211,214,12, 213, 12, 13,214,01610002 
. 1212, 3F6. 2,16, 2A 12, 8I6.A 12,12, 215, A5, 12, A2.F5. 2,14, 213, 214,11)  01620099 


GO  TO  195 

190  NC0UNT =NC0UNT+ 1 
195  CONTINUE 
GO  TO  100 

EXIT  MODULE 

202  WRITE (6. 203)  KCOUNT . LCOUNT , NCOUNT 

203  FORMAT ( 5X. 'RECOROS  READ IX . 19 , 10X RECORDS  WRITTEN  \I9.10X, 
1RDS  SKIPPED  '  .19) 

■"•THIS  MODULE  IS  RUN  TO  ASSIGN  A  DEGREE  OF  DIFFICULTY 
INDEX  TO  EACH  FACILITY  PRIOR  TO  TOPSIS  PROCESSING. 

PRELIMINARY  COMPUTATIONS  ARE  MADE  TO  DEVELOP  ATTRIBUTES. 
TOPSIS  COMPUTATIONS  ARE  GENERATED.  RED  FLAGS  ARE  IDENTIFIED 
AND  SCORED.  OVERALL  EFFECTIVENESS  IS  COMPUTED. 


-••THIS  SECTION  SELECTS  OATA  RECORDS  FROM  THE  INPUT  DISK  FILE. 
COMPARES  FSCM  WITH  CONTRACTOR  IMPROVEMENT  PROGRAM  FILE,  AND 
COMPUTES  AND  INDEX  BASED  ON  CIP,  MORS  AND  SEVERE  ODRS . 

CODES  ASSIGNED  ARE  1-4  AS  FOLLOWS:  1  IS  A  PROBLEM  RESIDENT 
FACILITY.  2  IS  A  NORMAL  RESIDENT,  3  IS  A  PROBLEM  NONRESIDENT  AND 
4  IS  A  NORMAL  NONRESIDENT. 

--•STEP  1  •*» 

•-■INITIALIZE  PARAMETERS 

REWIND  2 
I  FAC=0 
UFAC=0 
ICIPN0=O 

SET  THE  IDEAL  AND  NEGATIVE  IDEAL  CONDITIONS  AND  WEIGHT  FACTORS 
CALL  CORNER ( AIDEAL . AWORST . BIDEAL , BWORST , WEIGHT) 

READ  THE  MASTER  DATA  FILE 

DO  640  1=1.999 

READ  (10.641)  A(I,1).A(I,2),A(I,3).A(I,4),A(I.5),A(I.6),A(I.7), 
1A(I,8).A(I,9),A(I,  10) , A ( I , 1 1 ) . A ( I , 1 2 ) , A ( I , 1 3 ) , A ( I  .  14).A(I, 15), 

2A  (  I ,  16 ) , A( I , 1 7 ) , A ( I , 18 ) , A( I , 19 ) , A ( I , 20 ) , A( 1 , 2 1 ) ■ A ( I , 22 ) , A( I , 23  ) , 
3A(I,24).A(I,25),A(I,26),A(I,27),A(I,28).A(I,29),A(I.30).A(I,31), 
4A(I,32).A(I,33).A(I,34),A(I,35),A(I,36),A(I.37),A(I.38) 

641  FORMAT (3X,2F7.2.2F6.2,4F7.2,8F6.2,2F5.2,2F7.2,2F6.2,6F5.2,2F7.2, 
12F6.2.2F7.2.2F5.2.2F7.2) 

640  CONTINUE 

CHECK  TO  SEE  IF  CONTRACTOR  ALERT  OPTION  IS  ACTIVE 


IF  (ICIP  .EQ.  1)  GOTO  674 
C  READ  THE  CONTRACTOR  ALERT  FILE 
DO  671  1=1.2000 
ICIPNO=ICIPNO+ 1 
RE AD (8. 672, END=673 )  BFSCM(I) 

672  FORMAT (4X.A5.81X) 

671  CONTINUE 

C  IF  THIS  LOOP  IS  DONE  THE  ENTIRE  FILE  EXCEEDS  THE  ARRAY  LENGTH 

GO  TO  675 

673  ICIPNO  =  I - 1 

C  SET  DEFAULTS  TO  ZERO 

674  DO  670  1=1,120 
JCIP=0 
DEGREE ( I ) =0 

670  CONTINUE 

C  -"READ  FIRST  RECORD  FOR  FACILITY--- 

600  RE AD( 2 . 60 1 , END=666 )  DCASR( 1 ) . QAORG( 1 ) , FSCM( 1 ) , TYP ( 1 ) , CMDT Y ( 1 ) , 
1 PVM* 1 ) , MONTH ( 1 ) , YEAR( 1 ) , PLANHR ( 1 ) , LOT INS ( 1 ) , rVIHR ( 1 ) , PEHR(  1 5 , 


01630002 
01640002 
01650002 
01660002 
01670002 
01680002 
01690002 
01700002 
RECOO 17 10002 
01720002 
01730002 
01740002 
01750002 
01760002 
01770002 
01780002 
01790002 
01800002 
01810002 
01820002 
01830002 
01840002 
01350052 
01860002 
01870002 
01880002 
01890002 
01900002 
01910002 
01920030 
01930002 
01940099 
01950099 
01960099 
01970002 
01980002 
01990002 
02000052 
02010002 
02020002 
02030002 
02040002 
02050024 
02060025 
02070024 
02080002 
02090002 
02100002 
02110002 
02120002 
02130002 
02140002 
02150002 
02160098 
02170098 
02180002 
02190002 
02200002 
02210002 
02220002 
02230002 
02240099 
0225000? 
02260002 
02270002 
02280002 
02290042 


2AQDR( 1 ) ,BODR( 1 ) .CODR( 1 ) ,DQDR( 1) ,EQDR( 1 ) , ADMNHR( 1 ) , SHIPMT ( 1 ) ,  02300042 

3WD( 1 ) . INTHR( 1 ) , RE INHR( 1 ) . VISITf 1 ) . ECP( 1 ) ,MTGHR( 1),MRB( 1),PC0( 1).  02310042 

4CA0(1),  02320094 

5SI ( 1 ) . EPA( 1 ) . DEVN( 1 ) ,CONTR( 1 ) , DLRIN( 1 ) ,DLROUT( 1 ) , ACNTRT ( 1 ) .  02330099 

6BCNTRT ( 1 ) . OCNTRT ( 1 ) ,QALI IN( 1 ) ,QALIRE( 1 ) , AONHND( 1 ) , B0NHND( 1 ) ,  02340091 

700NHND( 1 ) , DLR0H( 1 ) , NQDR( 1 ) ,PVINP( 1 ) , PEELNP( 1 ) , OAR ( 1 ) ,  02350099 

8N0AR( 1 ) ,0PER( 1 ) . WMDR( 1 ) ,DAYSCL( 1 ) , ISE0( 1 ) ,RECS( 1 ) , ISTRAT( 1 ) ,  02360091 

9IPEER( 1 ) , IPRNT ( 1 )  02370091 

601  FORMAT (A6. A3, A6, A1 ,A2, A 1 ,212.414. 13,212,211 ,214.12,213,12,13,214,  02380002 
1212, 3F6. 2, 16, 2A 12, 816, A 12, 12, 215, A5, 12 , A2, F5 . 2 , 14 , 213 , 214 , 1  1)  02390099 
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JFAC  COUNTS  THE  FACILITIES  THAT  REACH  THIS  STEP. KB  COUNTS  THE  02400002 
NUMBER  OF  RECORDS  FOR  A  GIVEN  FACILITY  02410002 

JFAC=UFAC+1  02420002 

KB=1  02430002 

IF(ICIP  ,EQ.  1)  GOTO  604  02440002 

IF  THE  ALERT  OPTION  IS  ACTIVE.  CHECK  TO  SEE  IF  FSCM  IS  ON  ALERT  02450002 
CALL  CIP(KB ,  FSCM,  <JC IP  ,  ICIPNO)  02460099 

READ  ADDITIONAL  RECORDS  FOR  THE  FSCM  02470002 

604  DO  650  KB=2 . 120  024B0002 

REAO( 2 .601, END=666 )  DCASR(KB ) . QAORG(KB ) , FSCM(KB ) .TYP(KB) . CMDTY(KB02490002 


1 ) . PVN(KE) . MONTH! KB ) , YEAR(KB ) , PLANHR(KB) , LOT  INS ( KB ), PVIHR (KB ) , 


02500002 


2PEHR(KB ) . A0DR(KB ) . BODR(KB) , CODR (KB ) ,DQDR(KB ) , EODR(KB ) , ADMNHR(KB) ,  02510042 
3SHIPMT(KB) .WD(KB). INTHR(KB ) , REINHR(KB ) , VI SIT(KB ) . ECP(KB ) .  02520042 

4MTGHR(KB) .MRB(KB) .PCO(KB) .CAO(KB) .SI(KB) .EPA(KB) .DEVN(KB) ,  02530099 

5C0NTR(KB) .DLRIN(KB) .DLROUT(KB) . ACNTRT(KB) .BCNTRT(KB) .OCNTRT(KB) .  02540042 

GOALIIN(KB) .OALIRE(KB) . AONHND(KB ) ,BONHND(KB ) .OONHNDfKB ) .DLROH(KB) .  02550042 
7N0DRIKB ). PVINP ( KB ) , PEELNP(KB ) , OAR (KB ) . NOAR (KB ) .  02560099 

80PER(KB) .WMDR(KB),DAYSCL(KB). ISEO(KB) ,RECS(KB). ISTRAT(KB) .  02570042 

9IPEER(KB) . IPRNT(KB)  02580053 

KA=KB-1  02590002 

STOP  READING  IF  THIS  IS  THE  LAST  RECORD  FOR  FSCM  OR  A  NEW  FSCM  02610002 
APPEARS  02620002 

IF  (ISEO(KB)  .EQ.  RECS(KB))  GOTO  652  02630002 

IF  (FSCM(KB)  .GT.  FSCM(KA))  GOTO  651  02640002 

650  CONTINUE  02650002 

GO  TO  678  02660002 

651  NCTL  = 1  02670002 

GO  TO  654  02680002 

652  NCTL'O  02690002 

KA=KA+ 1  0270C002 

654  I F ( KA  .LT.  MONTHS)  GOTO  662  02710002 

IF  ENOUGH  DATA,  ASSIGN  DEGREE  OF  DIFFICULTY  INDEX  TO  FSCM  ARRAY.  02720002 
THEN  PREPARE  ARRAY  FOR  TOPSIS  BY  COMPUTING  INDICATORS.  02730002 

DO  660  L 1  =  1 , KA  02740002 

ONHAND( L 1 ) =AONHND (LI) +BONHND (LI) +OONHND( L 1 )  02750026 

CALL  DIFF(TYP.CODR.DODR,EODR,WMDR.L1 ,UCIP .DEGREE, I  PEER)  02760060 

IF  (LONG  .EQ.  0)  GOTO  660  02770002 

WRITE ( 4 . 66 1 )  DCASR( L 1  )  ,QAORG( L 1 ) , FSCM(L 1 ) , TYP(L 1 ) . CMDTY( L 1 ) ,  02780002 

1PVN( L 1 ) . MONTH( LI), YEAR (LI). PLANHR  (Li), LOT I NS ( Li), PVIHR( LI),  02790002 

2PEHR ( L 1 ) , AODR ( L 1 ) , BQDR ( L 1 ) . CQDR ( L 1 ) , DOOR ( L 1 ) . EODR ( L 1 ) , ADMNHR (LI),  02800002 

3SHIPMT(L1).WD(L1),INTHR(L1).REINHR(L1),VISIT(L1).ECP(L1),  02810002 

4MTGHR ( L 1 ) . MRB ( L 1 ) , PCO ( L 1 ) , CAO ( L 1 ) , SI  ( L 1 ) . EPA ( L 1 ) . DE VN( L 1 ) ,  02820099 

5C0NTR( LI).DLRIN(LI), DLROUT (Li ) , ACNTRT (LI), BCNTRT (LI), OCNTRT( Li) ,  02830002 

GOAL  1 1 N( L 1 ) . QAL I RE ( L 1 ) , AONHND( L 1 ) , BONHND( Li), OONHND (LI). DLROH( LI),  02840002 
7N0DR ( L 1 ) . PVI NP ( L 1 ) , PEELNP ( L 1 ) . NQAR ( L 1 ) , OPER ( L 1 ) , WMDR (Li),  02850099 

8DAYSCL(L1),ISEQ(L1).RECS(L1),IPEER(L1),L1,KA,UCIP.DEGREE(L1)  02860099 

661  F0RMAT(A6, A3, A6.A1 .A2.A1 ,212,414, 13.212,21 1,214,12,213,12,13,214,  02870002 

02880099 
02890002 
02900002 
02910002 
02920002 


12I2.3F6.2, 16. 2A 1 2, 816, A 12. 12, 21 5, 1 2, A2,F5. 2, 1 4, 21 3, 14, 41 3) 
660  CONTINUE 

COUNT  THE  FACILITIES  THAT  HAVE  SURVIVED. 

I F AC  =  I FAC+  1 

COMPUTE  TOPSIS  VALUES  FOR  FSCM 


CALL  PREPIN( KA , AODR , BODR , CODR . DODR , EODR , WD , ECP , MRB , EPA , DEVN , WMDR . 02930099 
1T0PCA , CARATE , WDRATE , ECPRAT , AMRBRA , EPARAT , DE VNRA , WMDRRA , STARTM ,  02940099 

2STARTY , ENDMO , ENDYR , FSCM, MONTH, YEAR , TOPWD , TOPECP , TOPMRB . TOPEPA ,  02950002 

3T0PDEV, TOPMDR , OCASR , OAORG , DEGREE , AIDE AL , AWORST . BI DEAL , BWORST ,  02960099 

41 STRAT . WE  I GHT . REINHR , INTHR .MTGHR , SHIPMT , LOTINS .VISIT, PVN, TYP ,  02970002 

5PEHR , CONTR . PLANHR , DA YSCL . PCO , CAO , NODR , SI , ADMNHR , PVINP ,  02980099 

6PEELNP .OALIIN.OALIRE, LONG, TOP SCR , PVIHR , ONHAND , OAR , IPRNT , I  PEER ,  02990095 

7CMDTY , NOAR )  03000099 

BEGIN  ANOTHER  FSCM,  03010002 

EITHER  READ  A  NEW  RECORD  OR  MOVE  LAST  RECORD  INTO  FIRST  POSITION  03020002 
662  I F (NCTL  .EO.  0)  GOTO  600  03030002 

CALL  NEWF AC ( KB, DCASR. OAORG, FSCM, TYP, CMDTY, PVN, MONTH. YEAR, PLANHR,  03040002 
1  LOT I NS . P  EHR , AODR , BODR . CODR , DODR , EODR , ADMNHR , SH I PMT , WD , I NTHR ,  03050002 

2RE INHR . VI S I T , ECP , MTGHR , MRB . PCO , CAO ,  03060094 

3SI . EPA , DEVN , CONTR , DLRIN, DLROUT ,  03070099 

4ACNTRT , BCNTRT , OCNTRT . OALI IN.QALIRE , AONHND , BONHND , OONHND , DLROH,  03080092 

5N0DR, PVINP, PFFl NP , NOAR , OPER , WMDR , OA YSCL , ISEO.RECS. ISTRAT,  03090099 

6JCIP, ICIPNO, ICIP, PVIHR, OAR. IPRNT, I  PEER)  03100098 

<JFAC=JFAC+ 1  03110002 

GO  TO  604  03120002 

C  ABNORMAL  TERMINATION  03130002 

675  WRITE(6 , 676)  ICIPNO  03140002 

676  FORMAT (5X. 'EXCESS  RECORDS  ON  CONTRACTOR  INPROVEMEnT  FI LE , OVER ' , 16 )03150002 

678  WRITE (6 , 679 )  03160002 

679  FORMAT (2X. 'ERROR  DETECTED.  VERIFY  INPUT  FILE  SORTED  BY  FSCM')  03170002 

C  NORMAL  TERMINATION  03180002 

666  WRITE(6 , 668 )  UFAC.IFAC  03190002 

668  F0RMAT(5X, 'FACILITIES  IN  '. 19 , 5X, ' FACILITIES  OUT  ',19)  03200002 
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WRITE (6 ,677 )  ICIPNO 
677  FORMAT ( 5X , 'CIP  FACILITIES 16 ) 

STOP 

ENO 

C 

SUBROUTINE  TIMCHK(M0NTH, I  YEAR . UERROR ) 

C  CHECKS  TIME  VALUES  ENTERED  FOR  INCONSISTENCY 
IF (I YEAR  .LT.  84)  GOTO  300 
I F( MONTH  .LT.  1)  GOTO  300 
IF (MONTH  .GT.  12)  GOTO  300 
JERROR-O 
GO  TO  310 
300  JERROR*  1 
310  RETURN 
END 
C 

SUBROUTINE  STRAT ( I , TYP , CMDTY , PVN , OPER . NOAR .  UJ . I SEQ . RECS . AVLHP ) 

ASSIGNS  A  STRATIFICATION  ID  NUMBER  TO  EACH  RECORD.  STRAT  ID 

15  USED  TO  GROUP  SIMILAR  FACILITIES.  THE  NUMBER  RANGES  INITIALLY 
FROM  1-742.  ID  VALUES  1-500  ARE  USED  FOR  NONRESIDENT  FACILITIES, 
RESIDENT  ARE  501-740.  REPAIR/OVERHAUL  FACILITIES  ARE  386,741, 

AND  742  FOR  NONRESIOENT ,  SMALL  RESIDENT  AND  LARGE  RESIDENT  RESP. 
NONASSIGNED  FACILITIES  ARE  PUT  IN  GROUP  385. 

CHARACTER  TYP( 1 20) *  1 . CMDTY ( 120)*2,PVN( 120) *  1 ,OPER( 120) *2 
INTEGER  NQAR( 120) . JJ( 1 20) . AVLHR{ 120) . ISEO( 120) . RECS( 120) 

I F ( ( OPER ( I )  .EO.  'C  ')  .OR.  (OPr(I)  .EQ.  '  C')  .OR. 

1  (CMDTY ( I )  .EO.  ' AS ' ) )  GOTO  58 

KK  IS  A  DORO  FORTRAN  UNIQUE  VALuE  L  1-16  REPRESENTING  THE 

16  COMMODITY  CODES  IN  DLAM  8200.2 
KK= ( I CHAR (CMDTY ( I ) ( 1 : 1 ) ))-192 

IF(KK  .GT.  33)  GOTO  501 
IF(KK  .GT.  9)  GOTO  502 
GO  TO  504 

501  KK=KK- 1 5 
GO  TO  504 

502  KK=KK-7 

504  IF  (KK  .EO.  16)  GOTO  515 

IF  (KK  .GT.  21)  GOTO  516 

IF  (KK  .GT.  18)  GOTO  517 

IF  (KK  .GT.  10)  GOTO  518 

IF  (KK  .GT.  6)  GOTO  519 
GO  TO  520 

515  KK=  1 2 
GO  TO  520 

516  KK=KK-8 
GO  TO  520 

517  KK=KK-6 
GO  TO  520 

518  KK=KK-3 
GO  TO  520 

519  KK=KK- 1 

520  IF  (KK  .GT.  16)  GOTO  599 

SPLIT  RESIDENT  FROM  NONRESIDENT 
IF(TYP(I)  .EO.  'N')  GOTO  550 

RESIDENT  ID  VALUES  DEPEND  ON  COMMODITY) 16) ,  OA  PR0V(3)  AND 
NUMeER  OF  OARS ( 4 ) . OARS  IS  COMPUTED  FOR  PRIOR  MONTHS 
IF(ISEO(I)  .LT  RECS(I  ))  NQAR(I )  =  INT ( FLOAT ( AVLHR( I )-3G)/149  0)  + 
C  COMBINE  SERVICE  WI1H  GENERAL  COMMODITIES 
I F ( KK  .EO,  13)  KK=6 
KKK=KK* 15-15 

C  OA  PROV  IS  EITHER  A  OR  B  OR  C  (MIL  0.  MIL  I  OR  OTHER) 

IF  (PVN(I)  .EO.  'A')  GOTO  526 
IF  (PVN(I)  .EO.  'B')  GOTO  528 
LL=  10 
GO  TO  530 
526  LL=0 

GO  TO  530 
528  LL=5 

530  IF  (NQAR(I)  -LE.  2)  GOTO  532 
IF  (NOAR(I)  .LE.  7)  GOTO  534 
IF  (NQAR(I)  .LE.  20)  GOTO  536 
MM=5 

GO  TO  540 
532  MM= 1 

GO  TO  540 
534  MM=2 

GO  TO  540 


03210002 

03220002 

03230002 

03240002 

03250002 

03260002 

03270002 

03280002 

03290002 

03300002 

03310002 

03320002 

03330002 

03340002 

03350002 

03360002 

03370099 

03380002 

03390002 

03400002 

03410046 

03420046 

03430046 

03440046 

03450002 

03460002 

03470099 

03480002 

03490067 

03500068 

03510002 

03520002 

03530002 

03540002 

03550002 

03560002 

03570002 

03580002 

03590002 

03600002 

03610002 

03620002 

03630002 

03640002 

03650002 

03660002 

03670002 

03680002 

03690002 

03700002 

03710002 

03720002 

03730002 

03740002 

03750002 

03760099 

03770002 

03780002 

03790099 

103800099 

03810099 

03820099 

03830002 

03840002 

03850002 

03860002 

03870002 

03880002 

03890002 

03900002 

03910002 

03920002 

03930002 

03940002 

03950002 

03960002 

03970002 

03980002 

03990002 

04000002 
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536  MM=3 

540  Jd( I ) ’KKK+LL+MM+500 

GO  TO  599 

ASSIGN  STRAT  ID  TO  NONRESIDENT  FACILITY 

VALUES  RANGE  FROM  1-500  DEPENDING  ON  2  ALPHA  COMMODITY  CODE 
IN  OLAM  8200.2(16*8)  AND  OA  PR0V(3) 
l»5»0  MMM  KK  *  24  24 
NN«0 

C  COMBINE  ALl  MIL-0  AT  1  ALPHA  FOR  C8T ,  MARINE,  CHEMICAL, 

C  NUCLEAR.  PETROLEUM,  SERVICE.  VEHICLES  AND  MISSILES/SPACE 

IF( ( PVN( I )  .£0.  'A')  .AND.  ((KK  .EQ.  3)  .OR.  (KK  .EQ.  4)  .OR. 

1  (KK  cO.  7)  .OR.  (KK  .EQ.  11)  .OR. 

2  (KK  .EQ.  12)  .OR.  (KK  .EQ.  13)  .OR.  (KK  .EQ.  14)  .OR. 

3  (KK  ,  EO.  16)))  GOTO  552 

NN=( 1CHAR(CKDTY( I ) ( 2 : 2 ) ) -240) *  3-3 
1 F ( PVN( I )  .EQ.  'A')  GOTO  552 
IF ( PVN( I )  .EQ.  'B' )  GOTO  554 

551  NNN=3 

GO  TO  556 

552  NNNC 1 

GO  TO  556 
554  NNN=2 

556  dd ( I ) =MMM+NN+NNN 

IF ( ( dd( I )  .GE.  13)  .AND.  ( dd ( I )  .LE.  15))  GOTO  598 
I F ( ( dd ( I )  .GE.  76)  .AND.  (dd(I)  .uE.  78))  GOTO  598 
C  COMEINE  DIFFERENT  STRATA 
CALL  STRAT2( I ,dd) 

GO  TO  599 

C  ASSIGN  STRAT  ID  TO  MAINTENANCE  FACILITIES 

598  dd( I ) =386 

I F ( ( TYP ( I )  .EQ.  'R')  .AND.  (NOAR(I)  .GE.  8))  Jd(I)'742 
I F ( ( TYP( I  )  EQ.  'R')  .AND.  (NQAR(l)  .LT.  8))  dd(I)=741 

599  IF (dd( I )  -EQ.  0)  dd( 1  )  =  385 
RETURN 

END 

SUBROUTINE  STRAT2( I , dd ) 

C  THIS  SUBROUTINE  COMBINES  NONRESIDENT  STRATA 
INTEGER  dd( 120) 

C  “COMBINE  HI  AND  H2“ •  *»..»»*.«»» •““““ » 

I F( ( dd( I  )  .EQ.  149) .OR. (dd(I )  .EQ.  150))  THEN 
dd(I )‘dd(I)-3 
RETURN 
END  IF 

C  “COMBINE  E2  AND  E6  FOR  MIL-Q  ONLY 
IF ( dd( I )  .EQ.  100)  THEN 
dd( I  )  =  1 1 2 
RETURN 
END  IF 

C  ‘‘COMBINE  G2  AND  G7  AND  G8  FOR  MIL-Q  ONLY  ***.**»»*».»«»•«*».. 
IF( (dd( I )  .EQ.  124)  .OR.  (dd(I)  .EQ.  139))  THEN 
dd( I  )  =  142 
RETURN 
END  IF 

C  “COMBINE  C5  AND  C6  FOR  MIL-I  ONLY 
IF (dd( I )  .EQ.  62)  THEN 
dd( I ) =65 
RETURN 
ENDIF 

C  “COMBINE  K4  AND  K7  EXCEPT  FOR  MIL-I 

I F ( ( dd( 1 ) . EQ. 178 )  0R.(dd(l ).EQ. 180))  THEN 
dd( I )=dd( I )  +  9 
RETURN 
ENDIF 

C  “COMBINE  W4  AND  W6  EXCEPT  FOR  MIL-I 

I F ( ( dd( I ) . EQ . 346 ) . OR . ( dd( I ) . EQ . 348 ) )  THEN 
dd( I )=dd( I )+G 
RETURN 
ENDIF 

C  “COMBINE  P5  AND  P6  MIL-1  ONLY 
I F ( dd ( I  )  .EQ.  281)  THEN 
dd(I )=278 
RETURN 
ENDIF 

C  “COMBINE  03  AND  D7  OTHER  INSP  ONLY  «“*******«*»»***»***»«*» 

I F ( dd( I )  .EO.  81)  THEN 
dd( I )=S3 
RETURN 
ENCIF 

C  “COMBINE  N4  AND  N5  OTHER  INSP  ONLY  “****“**«******»».«»**** 

I F ( dd( I )  .EO.  252)  THEN 


04010002 
04020046 
04030002 
04040002 
0405004o 
040G0002 
04070046 
04080002 
04090067 
04 100035 
04110035 
04120067 
04130037 
04140037 
04150002 
04160018 
04170002 
04180002 
04190002 
04200002 
04210002 
04220002 
04230002 
04240068 
04250068 
04260002 
04270002 
04280002 
C4290002 
04300046 
043-0057 
04320057 
04330046 
04340002 
04350002 
04360002 
04370002 
04380002 
04390018 
04400067 
04410002 
04420002 
04430002 
04440067 
04450067 
04460067 
04470035 
04480035 
04490067 
04500068 
04510067 
04520067 
04530067 
04540035 
04550046 
04560046 
04570002 
04580002 
04590035 
0460C046 
04610035 
04620035 
04630035 
04640035 
04650046 
04660035 
04670035 
04680035 
04690035 
047p0046 
047*10046 
04720002 
04730002 
04740035 
04750046 
04760046 
04770035 
04780035 
04790035 
04800046 
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<JiJ(  I )  =255 
RETURN 
ENDIF 
RETURN 
END 


C 

C  •»'  THIS  SUBROUTINE  TRANSLATES  STRAT  NUM8ERS  INTO  PEER  GROUP  NUMBERS 
C  RESIDENT  FACILITIES  ARE  BROKEN  OUT  TO  THE  SECOND  CMDY  ALPHA 
SUBROUTINE  PEERGP( I . I STRAT , 1  PEER .CMDTY . PVN. NQAR ) 

INTEGER  ISTRAT ( 120) . IPEER( 120) ,NQAR( 120) 

CHARACTER  CMDTY ( 120)'2.PVN( 120)' 1 
C  NONRESIDENT  FACILITIES  ARE  NOT  CHANGED. 

I  PEER ( I )*ISTRAT ( I ) 

I F ( ISTRAT ( I  )  .LT.  3S6)  GOTO  10 
C  MAINTENANCE  FACILITIES  ARE  BROKEN  OUT  FURTHER 
IF(IPEER(I)  .EO.  386)  THEN 
IF (CMDTY ( I ) ( 1 : 1 )  .EO.  'A')  THEN 
IPEERd  )*401 
GO  TO  10 
ENDIF 

IF(CMDTY( I )( 1 : 1 )  .EO.  'D')  THEN 
IPEER(I ) *404 
GO  TO  10 
ENDIF 

I F ( CMDTY ( I ) ( 1 : 1 )  .EO.  'E')  THEN 
IPEERf  I  )«=405 
GO  TO  10 
ENDIF 

1 F ( CMDTY ( I ) ( 1 : 1 )  .EO.  'G')  THEN 
IPEER( I ) =406 
GO  TO  10 
ENDIF 

IF(CMDTY ( I ) ( 1 : 1 )  .EO.  'K')  THEN 
IPEER(I )=408 
GO  TO  10 
ENDIF 

IF (CMDTY (1 ) ( 1 : 1 )  .EO.  'L')  THEN 
IPEERd  )=409 
GO  TO  10 
ENDIF 

I r ( CMDT Y ( I ) ( 1 : 1 )  .EO.  'M')  THEN 
IF ( PVN( I )  .EO.  'A' )  THEN 
IPEER( I ) =4  10 
GO  TO  10 
ENDIF 

I F ( PVN( I )  .EQ.  ' B ' )  THEN 

IF(CMDTY(I)  .EO.  'M3')  THEN 
IPEER( I )*412 
GO  TO  10 
ELSE 

IPEER(I)»411 
GO  TO  10 
ENDIF 
ELSE 

I F (CMDTY ( I )  .EO.  'Ml')  THEN 
IPEERI I ) =4 1 3 
GO  TO  10 
ENDIF 

I F ( CMDTY ( I )  .EO.  'M2')  THEN 
IPEER( I  )  =  4 14 


GO  TO  10 
ENDIF 

IF(CMDTY(I)  .EO.  'M3')  THEN 
IPEER( I  )=4  15 
GO  TO  10 
ENDIF 
ENDIF 
ENDIF 

IF(CMDTYU)dd)  EO.  'V")  THEN 
IPEERd  )  =4 19 
GO  TO  10 
ENDIF 

IF (CMDTY ( I )  (  1  :  1  )  .EO.  'X')  THEN 
IPEER(I )=420 
GO  TO  10 
ENDIF 

IPEERd  )=400 
GO  TO  10 
ENDIF 

IF(IPEERd)  .EO.  742)  THEN 


04810046 
04820035 
04830035 
04840002 
04850002 
04860047 
04670047 
04880047 
04890058 
04900047 
04910047 
04920067 
04930047 
04940067 
04950068 
04960068 
04970068 
04980068 
04990068 
05000068 
05010068 
05020068 
05030068 
05040068 
05050068 
05060068 
05070068 
05080068 
05090068 
05100068 
051 10068 
03120068 
05130068 
05140068 
05150068 
05160068 
05170068 
05180068 
05190068 
05200068 
05210068 
0^220068 
05230068 
05240068 
05250068 
05260068 
05270068 
05280068 
05290068 
05300068 
05310068 
05320068 
05330068 
05340060 
05350068 
05360068 
05370068 
05'I80068 
05390068 
05400068 
05410068 
05420068 
05430068 
05440068 
05450068 
05460068 
05470068 
05480068 
05490068 
05500068 
05510068 
05520068 
05530068 
05540068 
05550068 
05560068 
05570068 
05580068 
05590068 
05600067 
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.EQ.  'A')  THEN 


1 )  .EQ.  'L'  )  THEN 


1)  .EQ.  'M')  THEN 


•EQ.  'S')  THEN 


PEER  GROUPS  541-545 


IPEER(I)*999 
GO  TO  10 
END  IF 

SMALL  RESIDENT  MAINTENANCE  FACILITIES  BY  FIRST  COMMODITY  ALPHA 
IF(IPEERd)  .EQ.  741)  THEN 
IF(CMDTY(I)  .EQ.  'A5')  THEN 
IPEER( I )=980 
GO  TO  10 
END  IF 

I F (CMDTY ( I )( 1 : 1 ) 

I PE£R( I )  =  981 
GO  TO  10 
END  IF 

IF(CMDTY( I ) ( 1 
IPEER( I )=983 
GO  TO  10 
END  IF 

I F ( CMDTY( I )( 1 
IPE£R( I )=984 
GO  TO  10 
END  IF 

I F ( CMDTY ( I )  (  1 : 1 ) 

IPEER(  I  )"=985 
GO  TO  10 
ELSE 

IPEER(I )*982 
GO  TO  10 
ENDIF 
ENDIF 

BREAKOUT  AIRCRAFT  COMMODITY  --  RESERVE  GROUPS  501-550 
I F ( CMDTY ( I ) ( 1 : 1 )  .EQ.  'A')  THEN 
THIS  SECTION  OF  CODE  IS  FOR  AIRCRAFT  OTHER 
I F ( PVN( I )  . EQ.  'C' )  THEN 
IPEERd  )«IPEERd  )  +  30 
GO  TO  10 
ENDIF 

THIS  SECTION  OF  CODE  IS  FOR  AIRCRAFT  MIL-Q,  PEER  GROUPS  501-520 
Ir(PVN(I)  .EQ.  'A' )  THEN 
IF(NQAR(I)  .LT.  8)  THEN 

IPEERd )=IPEER(I)+((ISTRAT(I ) -501 ) *6)+ICHAR(CMDTY(I ) (2 : 2 ) 
GO  TO  10 
ELSE 

IF(NQAR(I)  .GT.  20)  THEN 
IPEER( I )=520 
GO  TO  10 
ELSE 

IF( ( CMDTY ( I ) ( 2 : 2 ) 

.OR.  ( CMDTY (I)(2:2).EQ.  '7'))  THEN 
IPEER( I  )  =5 17 
GO  TO  10 
ELSE 

I F (CMDTY ( I ) ( 2 : 2 ) 

I PEER( I )=515 
GO  TO  10 
ELSE 

I F ( CMDTY ( I ) ( 2 : 2 ) 

IPEER( I )=516 
GO  TO  10 
ELSE 

IPEER(I )=518 
GO  TO  10 
ENDIF 
ENDIF 
ENDIF 
ENDIF 
ENDIF 
ELSE 

SECTION  OF  CODE 
IF(KQARd)  .GT 
IPEERf I  )  =  I  PEER ( I 
GO  TO  10 
ELSE 

I r ( ( CMDTY (I ) ( 2 : 2 )  .EQ. 

THEN 

IP££R(I )=523 
GO  TO  10 
ELSE 

IPEER(I)=IPEER(I)+( ISTRAT ( I )-491 )+I CHAR ( CMDTY d ) ( 2 : 2 ) ) 
GO  TO  10 
ENDIF 


1 


■EQ.  '3')  .OR.  ( CMDTY d ) (2 : 2)  .EQ.  '6') 


■EQ.  '1')  THEN 


•EQ. '2' )  THEN 


THIS 


1 


IS  FOR  AIRCRAFT 
.  2)  THEN 
)  +  30 


MI L-I , PEER  GROUPS  521-540 


'3')  .OR.  ( CMDTY ( I ) (2 : 2)  .EQ.  '6')) 


05610067 
05620048 
05630048 
05640067 
05650067 
05660067 
05670067 
05680067 
05690067 
05700067 
05710067 
05720067 
05730067 
05740067 
05750067 
05760067 
05770067 
05780067 
05790067 
05800067 
05810067 
05820067 
05830067 
05840067 
05850067 
05860067 
05870067 
05880067 
05890067 
05900067 
05910048 
05920048 
05930048 
05940048 
05950048 
05960048 
05970048 
05980048 
05990048 
) -24 106000056 
06010048 
06020048 
06030048 
06040048 
06050048 
06060048 
06070048 
06080048 
06090056 
06100048 
06110048 
06120048 
06130048 
06140048 
06150048 
06160048 
06170048 
06180048 
06190048 
06200056 
06210048 
06220048 
06230048 
06240048 
06250048 
06260048 
06270048 
06280051 
06290048 
06300048 
06310048 
06320048 
06330048 
06340048 
06350048 
06360048 
06370048 
06380051 
06390048 
06400048 


-241 
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PEER  GROUPS  55 1 


ENDIF 

ENDIF 

ENDIF 

BREAKOUT  MUNITIONS  COMMODITY  --  RESERVE  GROUPS  551-575 
I F ( CMDTY( I )  ( 1 : 1 )  .EQ.  '3')  THEN 
THIS  SECTION  OF  CODE  IS  FOR  MUNITIONS  MIL-I,  PEER  GROUPS  5G6 
THIS  SECTION  OF  CODE  IS  FOR  MUNITIONS  OTHER,  PEER  GROUPS  571 
I F ( (PVN( I )  .EQ.  'B')  .OR.  (PVN(I)  .EQ.  'C'))  THEN 
IPEERO  )sIPEER(I)+45 
GO  TO  10 
ENDIF 

THIS  SECTION  OF  CODE  IS  FOR  MUNITIONS  MIL-Q,  PEER  GROUPS  551 
I F ( NQAR( I )  .LT.  6)  THEN 

IPEER(I  )  =  IPEER(I)  +  (ISTRAT(t )-5 16 )  *5+1 CHAR( CMDTY ( I ) ( 2 : 2 ) 
I F ( CMDTY( I ) ( 2 : 2 )  .EQ.  '5')  IPEER( I )=IPEER( I )-2 
IF(NQAR(I)  .GT.  2)  I PEER( I )  =  I PEER( I ) -  1 
GO  TO  10 
ELSE 

IF(NQAR(I)  .GT.  20)  THEN 
IPEER{ I ) =565 
GO  TO  10 
ELSE 

IPEER(I)=563 
GO  TO  10 
ENOIF 
ENDIF 
ENDIF 

BREAKOUT  MUNITIONS  COMMODITY  --  RESERVE  GROUPS  551-575 
I F ( CMDTY ( !  ) (  1  :  1 )  .EQ.  'B')  THEN 
THIS  SECTION  OF  CODE  IS  FOR  MUNITIONS  MIL-I.  PEER  GROUPS  566 
THIS  SECTION  OF  CODE  IS  FOR  MUNITIONS  OTHER.  PEER  GROUPS  571 
I F ( ( PVN( I )  . EQ.  'B')  .OR.  (PVN(I)  .EQ.  'C'))  THEN 
IPEERd)*IPEERd)+45 
GO  TO  10 
ENDIF 

THIS  SECTION  OF  CODE  IS  FOR  MUNITIONS  MIL-Q.  PEER  GROUPS  551 
IF(NQAR(I)  . LT .  8)  THEN 

IPEERd  ) =  I  PEER  ( I  )  +  ( ISTRATd  ) -5 16  )*5+ICHAR( CMDTY  ( I )  ( 2  :  2 ) 
I F ( CMDTY ( I ) (2: 2 )  .EQ.  '5')  IPEER(I )= IPEER(I ) -2 
IF (NQAR( I )  .GT.  2)  IPEER(I )*IPEER(I)-1 
GO  TO  10 
ELSE 

IF(NQARd)  .GT.  20)  THEN 
IPEER( I )=565 
GO  TO  10 
ELSE 

IPEER( I )=563 
GO  TO  10 
ENDIF 
ENDIF 
ENDIF 

BREAKOUT  CST  COMMODITY  --  RESERVE  GROUPS  576-600 
I F ( CMDTY ( I ) ( 1 : 1 )  .EQ.  'C')  THEN 
THIS  SECTION  OF  CODE  IS  FOR  CST  OTHER,  PEER  GROUPS  591-595 
I F ( PVN( I )  .EQ,  'C' )  THEN 
IPEER(I  )  =  IPEER(I )+50 
GO  TO  10 
ENDIF 

THIS  SECTION  OF  CODE  IS  FOR  CST  MIL-Q,  PEER  GROUPS  576-580 
IF(PVNd)  .EQ.  'A'  )  THEN 
IPEER( I )=I  EER(I )+45 
GO  TO  10 
ELSE 

THIS  SECTION  OF  CODE  IS  FOR  C&T  MIL-I, PEER  GROUPS  581-590 
IF(NQAR(I)  .GT.  2)  THEN 
IPEER(I)=IPEER(I )+50 
GO  TO  10 
ELSE 

I F ( ( CMDTY ( I ) ( 2 : 2 )  .EQ.  '1’)  .OR.  ( CMDTY ( I ) (2 : 2)  . EQ . 

1  .OR.  ( CMDTY ( I ) (2 : 2 )  .EQ.  '5')  .OR.  (CMDTY ( I ) ( 2 : 2 )  . EQ 

2  THEN 

IPEER(I )=581 
GO  TO  10 
ELSE 

IF ( CMDTY (I ) (2 : 2 )  .EQ.  '3')  THEN 
IPEER( I )=582 
GO  TO  10 
ELSE 

IPE£R( I )=583 
GO  TO  10 


’  )  THEN 


06410048 
06420048 
064300.48 
06440054 
06450054 
-570  06460054 

-575  06470054 

06480054 
06490054 
06500054 
06510054 
-565  06520054 

06530054 
>-241+3506540054 
06550054 
06560054 
06570054 
06580054 
06590054 
06600054 
06610054 
06620054 
06630054 
06640054 
06650054 
06660054 
06670054 
06680056 
06690056 
-570  06700056 

-575  06710056 

06720056 
06730056 
06740056 
06750056 
-565  06760056 

06770056 
>-241+3506780056 
06790056 
06B00056 
06810056 
06820056 
06830056 
06840056 
06850056 
06860056 
06870056 
06880056 
06890056 
06900056 
06910056 
06920056 
06930056 
06940056 
06950056 
06960056 
06970056 
06980056 
06990056 
07000056 
07010056 
07020056 
07030056 
07040056 
07050056 
07060056 
07070056 
07080056 
'  2 '  )  07090056 

.  '6' ) )  07100056 
07110056 
07120056 
07130056 
07140056 
07150056 
07160056 
07170056 
07 130056 
07190056 
07200056 
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END  IF 
END  IF 
END  IF 
ENDIF 
END  IF 

C  BREAKOUT  MARINE  COMMODITY  --  RESERVE  GROUPS  601-625 
I F ( CMDTY( I  )  ( 1 . 1 )  .EQ.  '0')  THEN 

C  THIS  SECTION  OF  CODE  IS  FOR  MARINE  OTHER.  PEER  GROUPS  621-625 
IFIPVNl I)  .ro.  'C' )  THEN 
1  PCI  R(  I  )>  'PURI  I  M65 
GO  10  10 
ENDIf 

C  THIS  SECTION  OF  CODE  IS  FOR  MARINE  MIL-0.  PEER  GROUPS  601-605 
IF(PVN(I )  . EO .  'A' )  THEN 
IPEERII )=IPEER(I )+55 
GO  TO  10 
ELSE 

C  THIS  SECTION  OF  CODE  IS  FOR  MARINE  MIL-I.PEER  GROUPS  606-620 
IF(NQARd)  .GT.  2)  THEN 
IPEERd  )  =  I»EER(I  )+60 
GO  TO  10 
ELSE 

I F (CMDTY ( I ) ( 2 : 2 )  .EO.  '5')  THEN 
IPEERI I ) =607 
GO  1 0  10 
ELSE 

IPEER( I )=606 
GO  TO  10 
ENDIF 
ENDIF 
ENDIF 
ENDIF 

C  BREAKOUT  ELECTRICAL  COMMODITY  --  RESERVE  GROUPS  626-650 
I F (CMDTY ( I )  1 1 ;  1 )  .EO.  'E')  THEN 

C  THIS  SECTION  OF  CODE  IS  FOR  ELECTRICAL  OTHER.  PEER  GROUPS  646-650 
IF(PVN( I )  .EO.  'C' )  THEN 
IPEERII  )  =  IPEERdJ+75 
GO  TO  10 
ENDIF 

C  THIS  SECTION  OF  CODE  IS  FOR  ELECTRICAL  MIL-0.  PEER  GROUPS  626-635 
IF(PVNII)  .EO.  'A')  THEN 
IFINOAR(I)  .LT.  8)  THEN 
IF (NQAR( I )  .LT.  3)  THEN 
I F ( CMDTY ( 1)12:2)  .EO.  '1')  THEM 
IPEERII )=626 
GO  TO  10 
ELSE 

I F ( CMDTY ( I ) ( 2 : 2 )  .EO.  '5')  THEN 
IPEERII )=628 
GO  TO  10 
ELSE 

IPEERI I ) =627 
GO  TO  10 
ENDIF 
ENDIF 
*  ELSE 

I F I ( CMDTY ( I ) ( 2 : 2 )  .EO.  '1')  .OR.  (CMDTY (I ) I  2 : 2 )  .EO.  '6')) 

1  THEN 

IPEERII )=629 
GO  TO  10 
ELSE 

IF ( ( CMDTY ( I)(2:2)  .EO.  '3')  .OR.  I CMDTY ( I)  ( 2 : 2  )  .EO.  '4')) 
1  THEN 

IPEERI I )=631 
GO  TO  10 
ELSE 

I F ( CMDTY ( I ) ( 2 : 2 )  .EO.  '2')  THEN 
IPEERI I ) =630 
GO  TO  10 
ELSE 

IPEERI I )=632 
GO  TO  10 
ENDIF 
ENDIF 
ENDIF 
ENDIF 
ELSE 

IPEERII )=IPEER(I)+70 
GO  TO  10 
ENDIF 


07210056 

07220056 

07230056 

07240056 

07250056 

07260057 

07270057 

07280057 

07290057 

07300059 

07310057 

07320057 

07330057 

07340057 

07350057 

07360057 

07370057 

07380057 

07390057 

07400057 

07410057 

07420057 

07430057 

07440057 

07450057 

07460057 

07470057 

07480057 

07490057 

07500057 

07510057 

07520057 

07530057 

07540057 

07550057 

07560057 

07570057 

07580057 

07590057 

07600057 

07610057 

07620057 

07630057 

07640057 

07650057 

07660057 

07670057 

07680057 

07690057 

07700057 

07710057 

07720057 

07730057 

07740057 

07750057 

07760057 

07770057 

07780057 

07790057 

07800057 

07810057 

07820057 

07830057 

07840057 

07850057 

07860057 

07870057 

07880057 

07890057 

07900057 

07910057 

07920057 

07930057 

07940057 

07950057 

07960057 

07970057 

07980057 

07990057 

08000057 
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c 


c 


c 


c 

c 


c 

c 


c 


.£0.  '3')  THEN 


'5' )  THEN 


ELSE 

THIS  SECTION  OF  CODE  IS  FOR  ELECTRICAL  MIL-I.PEER  GROUPS  63G-645 
IF(NQARfl)  .GT.  2)  THEN 
IPEER(I)*IPEER(I)+75 
GO  TO  10 
ELSE 

I F(  ( CMDTY  ( I )  (  2 : 2 )  .£0.  '1')  .OR.  (CMDTY ( I ) ( 2 : 2 )  .EQ.  '2') 

1  .OR.  ( CMDTY ( I ) ( 2 : 2 )  .EQ.  '4'))  THEN 

IPEERf I )=636 
GO  TO  10 
ELSE 

IF ( CMDTY ( 1 ) ( 2: 2) 

IPEERII )=637 
GO  TO  10 
ELSE 

I F ( CMDTY { I ) ( 2 : 2 )  .EQ. 

IPEER( I ) *638 
GO  TO  10 
ELSE 

IPEERf I)=639 
GO  TO  10 
ENOIF 
ENDIF 
ENDIF 
ENOIF 
ENDIF 
ENDIF 

BREAKOUT  GENERAL/SERVICE  COMMODITY  --  RESERVE  GROUPS  651-675 

I F ( ( CMDTY  ( I )  (  1 : 1 )  .EQ.  'G' )  .OR.  (CMDTY ( I  )  ( 1 : 1 )  .EO.  'S'))  THEN 
THIS  SECTION  OF  CODE  IS  FOR  GENERAL/SERV  OTHER.  PEER  GROUPS  671-675 
IF (PVN(I )  .EQ.  'C'  )  THEN 
IPEERI I )= IPEERf I )+85 
GO  TO  10 
ENDIF 

THIS  SECTION  OF  CODE  IS  FOR  GENERAL/SERV  MIL-Q,  PEER  GROUPS  651-655 
IF (PVN( I )  .£0.  'A' )  THEN 

I F ( ( CMDTY (I ) (2 : 2 )  .EQ.  '6')  .AND.  (NQAR(I)  .LT.  3))  THEN 
IPEERf! )=654 
GO  TO  lO 
ELSE 

IPEERd  )»IPEER(I  )+75 
GO  TO  10 
ENDIF 
ELSE 

THIS  SECTION  OF  CODE  IS  FOR  GENERAL/SERV  MIL-I.PEER  GROUPS  656-570 
IF(NQAR(I)  -GT.  2)  THEN 

IPEERd  )»IPEER(I)+80 

GO  TO  10 
ELSE 

I F ( CMDTY (I  )  ( 2  :  2 )  .EQ.  '6')  THEN 
IPEER( I ) =657 
GO  TO  10 
ELSE 

I F ( CMDTY ( I ) ( 2 : 2 )  .EQ.  '8')  THEN 
IPEERd  )  =658 
GO  TO  10 
ELSE 

IPEER( I ) =656 
GO  TO  10 
ENDIF 
ENDIF 
ENDIF 
ENDIF 
ENDIF 

eREAKOUT  CHEMICAL  COMMODITY  --  RESERVE  GROUPS  676-700 
I F ( CMDTY ( I ) ( 1 : 1 )  .EQ.  'H' )  THEN 

THIS  SECTION  OF  CODE  IS  FOR  ALL  CHEMICAL  PROVS,  PEER  GROUPS  676-690 
IPEERd  )  =  IPEER(  I  )+85 
GO  TO  10 
ENDIF 

8REAK0UT  ELECTRONIC  SYSTEMS  COMMODITY  --  RESERVE  GROUPS  701-750 
I F ( CMDTY (I ) M :  1 )  .EQ.  'K')  THEN 

THIS  SECTION  IS  FOR  ELECTRONIC  SYSTEMS  OTHER.  PEER  GROUPS  746-750 
IF(PVN( I )  .EO.  'C' )  THEN 
IPEERf I )°  IPEERf  I  1+130 
GO  TO  10 
ENDIF 

THIS  SECTION  IS  FOR  ELECTRONIC  SYSTEMS  MIL-Q.  PEER  GROUPS  701-725 
IFfPVNf I )  .EQ.  'A' )  THEN 
IF(NQARfl)  . LE .  20)  THEN 


08010057 
08020057 
08030057 
08040057 
08050057 
08060057 
08070057 
08080057 
08090057 
08100057 
08110057 
08120057 
08130057 
08140057 
08150057 
08160057 
08170057 
08180057 
08190057 
08200057 
08210057 
08220057 
08230057 
08240057 
OB250057 
08260057 
08270057 
08280057 
08290057 
08300057 
08310057 
08320057 
08330057 
08340057 
08350057 
08360057 
08370057 
08380057 
08390057 
08400057 
08410057 
08420057 
08430057 
08440057 
08450057 
08460057 
08470057 
08480057 
08490057 
08500057 
08510057 
08520057 
08530057 
08540057 
08550057 
08560057 
08570057 
08580057 
08590057 
08600057 
08610057 
08620057 
08630057 
08640057 
08650057 
08660057 
08670057 
08680057 
08690057 
08700057 
08710057 
08720057 
08730057 
08740057 
OB 7 5005 7 
08760057 
08770057 
08780057 
08790057 
08800099 
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IPEERI I )*IPEER( I )+((ISTRAT( I ) -606 ) *7 )+ICHAR(CMDTY ( I ) ( 2 :2 ) )-24 108810057 


+95 


IF( (NQAR( I )  .GT.  7)  .AND.  ( (CMDTY ( I )  ( 2 : 2 )  ,E0.  '4')  .OR. 

1  ( CMDTY ( I ) ( 2 : 2 )  .EQ.  '6')))  IPEER( I  )  =  IPEER( I )- 1 

GO  TO  10 
ELSE 

IPEER( I )*725 
GO  TO  10 
ENDIF 
ELSE 

THIS  SECTION  IS  FOR  ELECTRONIC  SYSTEMS  M1L-I.PEER  GROUPS  726-745 
IPEER( I  )  =  IPEER( I )+1 15 
GO  TO  10 
ENDIF 
ENDIF 

BREAKOUT  ELECTRONICS  COMMODITY  --  RESERVE  GROUPS  751-800 
I  F  ( CMD1  i  I  1  )(  1  1  )  .1.0.  '  L  '  )  THEN 


08820057 

08830057 

08840057 

08850057 

08860057 

08870057 

08880057 

08890057 

08900057 

08910057 

08920057 

08930057 

08940057 

08950057 

08960057 

08970057 


THIS  SF.CTION  OF  CODE  IS  FOR  ELECTRONICS  OTHER.  PEER  GROUPS  786-800  08980084 

IF(PVN'I)  .EQ.  'C')  THEN  08990057 

IPEERII )=IPEER(I)+155  09000057 

I F ( ( NQAR ( I )  .LT.  3). AND.  ( CMDTY ( I ) ( 2 : 2 ) . EQ .  '4'))  IPEER(I)  =  791  09010057 

GO  TO  10  09020057 

ENDIF  09030057 

THIS  SECTION  OF  CODE  IS  FOR  ELECTRONICS  MIL-Q.  PEER  GROUPS  751-770  09040057 

IF(PVN(I)  .EO.  'A')  THEN  09050057 

I F ( NQAR ( I )  .  LT.  8)  THEN  09060057 

IPEERI I )  =  IPEER( I )  +  ( ( ISTRAT I I ) -62 1 )*5 )+ICHAR! CMDTY ( I ) ( 2 : 2 ) ) -24 109070057 
+130  09080057 

I F  ( ( NQAR(  I  )  .  GT  .  2)  .AND.  ( CMDTY  ( I )  ( 2  :  2  )  .EQ.  '1'))  I  PEE  IT  (D*  09090057 
761  09100069 

I F ( ( NOAR  (  I  )  .GT.  2)  .AND.  ( CMDTY ( I ) ( 2 : 2 )  .EQ.  '4'))  I  PEER! I )=  09 1 10057 
758  09120065 

GO  TO  10  09130057 

ELSE  09140057 

IPEERII )=IPEER( I )+140  09150057 

GO  TO  10  09160057 

ENDIF  09170057 

ELSE  09180057 

THIS  SECTION  OF  CODE  IS  FOR  ELECTRONICS  MIL-I.PEER  GROUPS  771-785  09190084 

IFINOAR(I)  .GT.  2)  THEN  09200057 

IPEERI I )= IPEERI I )  + 1  SO  09210057 

GO  TO  10  09220057 

I F ( CMDTY ( I ) ( 2 : 2 )  .EQ.  '3')  THEN  09240058 

IPEERI I >*775  09250057 

GO  TO  10  09260057 

ELSE  09270057 

IPEERI I )=IPEER( I )+ICHAR( CMDTYI I ) ( 2 : 2 ) ) -24 1+145  09280057 

GO  TO  10  09290057 

ENDIF  09300057 

ENDIF  09310057 

ENDIF  09320057 

ENDIF  09330057 

BREAKOUT  MECHANICAL  COMMODITY  --  RESERVE  GROUPS  801-825  09340058 

IF (CMDTYI I ) ( 1 : 1 )  .EO.  'M' )  THEN  09350058 

THIS  SECTION  OF  CODE  IS  FOR  MECHANICAL  OTHER.  PEER  GROUPS  821-825  09360058 

IF(PVNII)  .EQ.  'C')  THEN  09370058 

IPEERI I )=IPEER( I )+175  09380058 

GO  TO  10  09390058 

ENDIF  09400058 

THIS  SECTION  OF  CODE  IS  FOR  MECHANICAL  MIL-Q,  PEER  GROUPS  801-810  09410058 

IFIPVN(I)  .EQ.  'A')  THEN  09420058 

IF(NQARII)  .LT.  8)  THEN  09430058 

IPEERI I >=IPEER( I )+( ( ISTRAT (I)-636)*3 )+ICHAR( CMDTY { I ) ( 2 : 2 ) ) -24 109440058 
1  +165  09450058 

IF(INUARII)  .GT.  2)  .AND.  (CMDTYI I ) I  2 : 2 )  .EQ.  '2'))  IPEERI I )*  09460058 


1  807  09470084 

GO  TO  10  09480058 

ELSE  09490058 

IPEER(I)=IPEER(I)+170  09500058 

GO  TO  10  09510058 

ENDIF  09520058 

ELSE  09530058 

THIS  SECTION  OF  CODE  IS  FOR  MECHANICAL  MIL-I.PEER  GROUPS  811-820  09540058 

IF ( NQAR I  I )  .GT.  2)  THEN  09550058 

IPEERI I )=IPEER( I >+175  09560058 

GO  TO  10  09570058 

ELSE  09580058 

IPEERI I ) “IPEERI I )+ICHAR( CMDTY( I )(2:2) )— 241+170  09590058 

GO  TO  10  09600058 
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END  IF 
ENOIF 
ENDIF 

C  BREAKOUT  NUCLEAR  COMMODITY  --  RESERVE  GROUPS  82S-850 
I F ( CMDTY (11(1:1)  .£0.  'N' 1  THEN 

C  THIS  SECTION  OF  CODE  IS  FOR  NUCLEAR  OTHER.  PEER  GROUPS  84G-850 
I F  ( PVN(  I  )  .  EO.  'C'  )  THEN 
IPEER( I )=IPEER( I )+ 185 
GO  TO  10 
ENDir 

C  THIS  SECTION  OF  CODC  IS  FOR  NUCLEAR  MIL-0.  PEER  GROUPS  826-835 
I F ( PVN( I )  .EO.  'A' )  THEN 
IF(NOAR(I)  .LT.  8)  THEN 
IF (NOAR( I )  .GT.  2)  THEN 
I F ( CMDTY ( I ) ( 2 : 2 )  .EO.  '2')  THEN 
IPEER(I 1=832 
GO  TO  10 
ELSE 

IPEER( I (=831 
GO  TO  10 
ENDIF 
ELSE 

IF ( ( CMDTY d ) ( 2 : 2 )  .EO.  '1').0R.  ( CMDTY ( I )  ( 2 : 2 )  .EO.  '4') 
1  .OR.  ( CMDTY ( I ) ( 2 : 2 )  EO.  '5'))  THEN 

IPEER( I 1  =  826 
GO  TO  10 
ELSE 

IF(CMDTY(I 1(2:2)  .EO.  '2')  THEN 
IPEERl 11=827 
GO  TO  10 
ELSE 

IPEER(I 1=828 
GO  TO  10 
ENDIF 
ENDIF 
ENDIF 
ELSE 

IPEERd )=IPEER(I 1+180 
GO  TO  10 
ENDIF 
ELSE 

C  THIS  SECTION  OF  CODE  IS  FOR  NUCLEAR  MIL-I.PEER  GROUPS  836-845 
IF(NQAR(I)  -GT.  2)  THEN 
IPEER(I)=IPEER(I)+185 
GO  TO  10 
ELSE 

I F ( (CMDTY ( I ) ( 2 : 2 ) . EO-  '1')  .OR.  (CMDTY ( I ) ( 2 : 2 )  .EO.  '4') 
1  .OR.  ( CMDTY ( I ) ( 2 : 2 )  .EO.  '5'))  THEN 

IPEERl 11=836 
GO  TO  10 
ELSE 

IF(CMDTY(I )(2:2)  .EO.  '2')  THEN 
IPEER(I 1=837 
GO  TO  10 
ELSE 

IPEERl I  1  =  838 
GO  TO  10 
ENOIF 
ENDIF 
ENDIF 
ENDIF 
ENDIF 

C  BREAKOUT  PETROLEUM  COMMODITY  --  RESERVE  GROUPS  851-875 
I F (CMDTY ( I )  (  1 : 1 1  EO.  ' P ' )  THEN 

C  THIS  SECTION  OF  CODE  IS  FOR  ALL  PETROLEUM  PROVS 
IPEER(I)=IPE£R(I)+185 
GO  TO  10 
ENDIF 

C  BREAKOUT  VEHICLE  COMMODITY  --  RESERVE  GROUPS  876-900 
I F ( CMDTY (11(1-1)  . EO  'V'l  THEN 

C  THIS  SECTION  OF  CODE  IS  FOR  ALL  VEHICLE  PROVS 
IPEER(I )*IPEER(I 1+180 
GO  TO  10 
ENDIF 

C  BREAKOUT  WEAPONS  COMMODITY  --  RESERVE  GROUPS  901-925 
I F ( CMDTY ( I ) ( 1 :  1  1  .EO.  'W' 1  THEN 

C  THIS  SECTION  OF  CODE  IS  FOR  ALL  WEAPONS  PROVS 
IPEER(I)=IPEER(I)+190 
GO  TO  10 
ENDIF 


09610058 

09620058 

09630058 

09640058 

09650058 

09660058 

09670058 

09680058 

09690058 

09700058 

09710058 

09720058 

09730058 

09740058 

09750058 

09760058 

09770058 

09780058 

09790058 

09800058 

09810058 

09820058 

09830058 

09840058 

09850058 

09860058 

09870058 

09880058 

09890058 

09900058 

09910058 

09920058 

09930058 

09940058 

09950058 

09960C58 

09970058 

0998005B 

09990058 

10000058 

10010058 

10020058 

10030058 

10040058 

10050058 

10060058 

10070058 

10080058 

10090058 

10100058 

101 10058 

10120058 

10130058 

10140058 

10150058 

10160058 

10170058 

10180058 

10190058 

10200058 

10210058 

10220058 

10230058 

10240058 

10250058 

10260058 

10270058 

10280058 

10290058 

10300058 

10310058 

10320058 

10330058 

10340058 

10350059 

10360059 

10370059 

10380059 

10390059 

10400059 
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BREAKOUT  MISSILES/SPACE  COMMODITY  --  RESERVE  GROUPS  926-950 
I F ( CMDTY ( I ) ( 1 : 1 )  .EQ.  'X')  THEN 

THIS  SECTION  IS  FOR  MISSILES/SPACE  MIL-I&OTHER,  PEER  GROUPS  941-950 
IF ( ( PVN( I )  .EQ.  'B')  .OR.  (PVN(I)  .EQ.  'C'))  THEN 
IPEER(I)=IPEER(I)+210 
GO  TO  10 
ENDIF 

THIS  SECTION  IS  FOR  MISSILES/SPACE  MIL-Q,  PEER  GROUPS  926-940 
IF(NQAR(I)  .LE.  20)  THEN 

IPEER(I )=IPEER(I )+((ISTRAT(I ) -726 ) *4 )+ICHAR(CMDTYU ) (2 : 2 ) )-24 
1  +200 


IF ( CMDTY ( I ) ( 2 : 2 )  .EQ.  '4')  IPEER( I )  =  IPEER( I  )- 1 
IF (CMDTY ( I ) (2 : 2)  .EQ.  '5')  IPEER( I )=IPEER( I  )-2 
GO  TO  10 
ELSE 

IPEER( I )=940 
GO  TO  10 
ENDIF 
ENDIF 
10  RETURN 
END 

***  THIS  SUBROUTINE  ASSIGNS  A  DIFFICULTY  INDEX  TO  A  FACILTY  OF  1  TO  4 
SUBROUTINE  DIFF (TYP . CQDR .DOOR , EQDR . WMDR , L 1 , JCIP . DEGREE . I  PEER  ) 
CHARACTER  T YP ( 120)* 1 

INTEGER  CQDR( 120) ,DQDR( 120) . EQDR( 120) .DEGREE ( 120),IPEER( 120) 

REAL  WMDR( 120) . AAVG( 120 ) , A ( 999 , 38 ) 

COMMON  /RVAR/A 

RESIDENT  ASSIGNMENT  IS  1  OR  2.  NORMAL  IS  2.  PROBLEM  IS  1. 
NONRESIDENT  ASSIGNMENT  IS  3  OR  4  DEPENDING  ON  ALERT  MATCH.  MDR 
ACTIVITY  OR  CORRCTI VE  ACTIONS  C  D  E. NORMAL  IS  4.  PROBLEM  IS  3. 
ASUM=0 . 0 
AAVG( L 1 )  *0.0 
IBAD=0 
NEWMDR=0 

IF  (dCIP  .EQ.  1)  IBAD= IBAD+ 1 
I F ( L 1 .  GT.  2)  THEN 

I F (CQDR( L 1 )+CQDR( L 1-1 )+CQDR( L 1 -2 )  .GT.  0)  IBAD=IBAD+1 
I F ( EQDR( L 1 )+EQDR( L1-1)+EQDR(L1-2)  .GT.  0)  IBAD=IBAD+1 
ELSE 

IF(CQDR(L1)  .GT.  O)  IBA0=IBAD+1 
I F ( EODR( L 1 )  .GT.  O)  IBAD=IBAD+1 
ENDIF 

00  15  KK=1 .LI 

IF  (DQDR(KK) .GT.  0)  I8AD=IBAD+1 
ASUM=ASUM+WMDR(KK) 

AA VG( KK ) = ASUM/REAL ( KK ) 

I F (KK  .LT.  LI-2)  GOTO  15 
IF (WMDR(KK)  .NE.  0.0)  NEWMDR=NEWMDR+ 1 
15  CONTINUE 

IF(TYP(L1)  .EQ.  'R' )  THEN 

I F ( AAVG( L 1 )  .GT.  ( A ( I PEER( L 1 ) , 35)+A ( IPEER ( L 1 ) . 36 ) ) )  IBAD=IBAD+ 1 
DEGREE ( L 1  )  =2 

I F ( IBAD  . GE .  2)  DEGREE ( L  1 )  =  1 
ELSE 

I F ( NEWMDR  GT  0)  IBAD= IBAD+1 
DEGREE ( l 1 )=4 

! F ( IBAD  .GE.  2)  DEGREE ( L 1 ) =3 
ENDIF 
RETURN 
END 

THIS  SUBROUTINE  COMPARES  THE  FSCM  OF  RECORD  WITH  THE  ALERT  FILE. 
IF  THERE  IS  A  MATCH  A  VALUE  OF  1  IS  ASSIGNED  TO  JCIP. ELSE  IT'S  0. 
SUBROUTINE  CIP( d , AFSCM, dCIP . ICIPNO ) 

CHARACTER  AFSCM( 120) *6 ,BFSCM( 2000) *5 , FLAG( 120)*18 
COMMON  /CHTR/BFSCM, FLAG 
DO  10  1=1. ICIPNO 

I  F  (  AFSCM(  d )  ( 2  :  6 )  .EQ.  BFSCM(D)  GOTO  25 
10  CONTINUE 

GO  TO  OC 
Id  •  V  Jd 

25  dCIP=1 
GO  TO  40 
35  dCIP=0 
40  RETURN 
END 

***  THIS  SUBROUTINE  IS  CALLEO  WHEN  A  NEW  FSCM  IS  READ. 

THE  CONTENTS  OF  THE  NEW  FSCM  ARE  MOVED  TO  THE  FIRST  POSITION  OF 
FACILITY  ARRAY 

SUBROUT  I NE  NEWF AC ( d , DCASR . QAORG , FSCM. TYP , CMDTY , PVN , MONTH .YEAR. 


10410059 
10420059 
10430059 
10440059 
10450059 
10460059 
10470059 
10480059 
10490099 
110500059 
10510059 
10520059 
10530059 
10540059 
10550059 
10560059 
10570059 
10580059 
10590059 
106C0047 
10610047 
10620047 
. 10630002 
10640060 
10650002 
10660099 
10680052 
10690002 
10700098 
10710002 
10720098 
10730098 
10740002 
10750002 
10760098 
10770099 
10780099 
10790099 
10800099 
10810099 
10820099 
10830099 
10840099 
10850002 
10860002 
10870002 
10880005 
10890098 
10900098 
10910002 
10920098 
10930098 
10940098 
10950098 
10960098 
10970098 
10980098 
10990098 
1 1000098 
1 1010098 
1 1020002 
1 1030002 
1 1040002 
1 1050099 
1 1060099 
1 1080002 
1  1090002 
1  1 1 10099 
1 1 120002 
1  1 130002 
11140099 
1  1 150098 
1  1160099 
1  1 170002 
1 1180002 
1 1 190002 
1 1200002 
1 1210002 
1  1220002 
1  1230002 


1PLANHR . LOT  INS . PEHR , AODR , BOOR . CODR .DOOR , EODR , ADMNHR , SHIPMT , WD . 1NTHR 1 1240002 

2  ,  RE  I NHR , VISIT, ECP.MT  GHR , MRB  .  PCO ,  CAO  , 

1  1250094 

3 SI . CPA, DC VN. CON IR. DIR  IN. DIROUT, 

1  1260099 

4  ACNI R1  .  BCNT R I  .  OCNT  RT  ,  OAL 1 1 N .  OAI.  1  RE  .  AONHND .  BONHND ,  OONHND ,  DL ROH . 

1 1270092 

iiNQDR  .  PV 1 NP  ,  PEELNP . NOAR ,  OPER  .  WMDR  .  DAYSCL  .  I SEO ,  RECS  .  1  STRAT  , 

1 1280099 

6dCIP, ICIPNO, ICIP.PVIHR.OAR, IPRNT, I  PEER) 

1 1290098 

C 

1 1300002 

CHARACTER  DCASR( 120) *6 , OAORG( 120)*3,FSCM( 120)*6,TYP( 120)*1  , 

1  1310002 

1CMDTY ( 120)*2,PVN( 120) » 1 ,OPER( 120) *2 , BFSCM( 2000) *  5 ,QAR( 120) *5. 

1 1320099 

2FIAG( 120)* 18 

1 1321099 

INTEGER  MONTH ( 120) . YEAR( 120) ,PLANHR( 120) ,LOTINS( 120) ,AODR( 120) . 

1 1330002 

1B0DR( 120) , CODR ( 120) ,DOOR( 120) , EODR ( 120) .ADMNHR ( 120) ,SHIPMT( 120) . 

1 1340002 

2WD( 120) , INTHR( 120) ,REINHR( 120) . VISIT( 120) . ECP( 120) ,MTGHR( 120) . 

1  1350002 

3MRB( 120) ,PCO( 120) ,CAO( 120) ,CONTR( 120) ,ISTRAT( 120) , 

1 1360099 

4DLRIN( 120) ,DLROUT( 120) , ACNTRT( 120) , BCNTRT ( 120) ,OCNTRT( 120) . 

1 1370002 

50ALI IN(120),QALIRE( 120) ,AONHND( 120) ,BONHND( 120) ,OONHND( 120) . 

1  1380002 

6DLR0H( 120) ,NODR( 120) ,PVINP( 120) ,PEELNP( 120) ,NOAR( 120) . 

1 1390099 

7ISE0( 120) , RECS( 120) ,DAYSCL( 120) , PEHR{ 1 20) . PVIHR( 120) . IPRNT ( 120) , 

1 1400044 

8IPEER! 120) 

1 1410098 

REAL  WMDR! 120) . SI ( 120) . EPA( 120) ,DEVN( 120) 

1 1420099 

* 

COMMON  /CHTR/BFSCM, FLAG 

1 1430002 

IF  (ICIP  .EO,  1)  GOTO  1 

1 1440002 

CALL  CIPId.FSCM.dCIP. ICIPNO.TYP) 

1 1450098 

1  OCASR! 1 )=OCASR(d) 

1 1460002 

QAORG( 1  )=QA0RG(d) 

1 1470002 

FSCM( 1 ) =FSCM( J ) 

1 1480002 

TYP (  1  )=TYP(d) 

1 1490002 

PVN( 1 )=PVN(d) 

11500002 

CMDTY ( 1 )=CMDTY(d) 

1 1510002 

MONTH! 1 )=MONTH!d) 

11520002 

YEAR(  1  )=YEAR(d) 

11530002 

PLANHR( 1 ) “PLANHR! U ) 

11540002 

PVIHR( 1 )=PVIHR(d) 

11550002 

LOTINS! 1 )=LOTINS(d) 

1 1560002 

PEHR( 1 ) =PEHR( J ) 

1 1570002 

AODR( 1 )=AQDR(d) 

11580002 

BODR( 1 )=BQDR(d) 

1 1590002 

CODR ( 1 ) cCQDR( d ) 

1 1600002 

DODR( 1 )=DODR(d) 

11610002 

EODR( 1 )  =  EQDR( d ) 

1 1620002 

ADMNHR( 1 )=ADMNHR(d) 

1 1630002 

SHIPMT( 1 )=SHIPMT(d) 

1 1640002 

WD ( 1 ) =WD ( d ) 

1 1650002 

INTHR( 1 ) = INTHR( d ) 

1 1660002 

REINHR! 1 )=REINHR(d) 

1 1670002 

VIS.T! 1 )=VISIT(d) 

1 1680002 

ECP( 1 )  =  ECP( d  ) 

1 1690002 

MT  GHR ( 1 ) =MT  GHR ( d ) 

1 1700002 

MRB( 1 ) =MRB( d ) 

1 1710002 

PC0(1)=PC0(d) 

11720002 

CAO( 1 )=CAO(d) 

1 1730002 

SI ( 1 )=SI (d) 

1 1740002 

EPA ( 1 ) =EPA ( d ) 

1 1750092 

DEVN! 1 )=DEVN(d) 

1 1760099 

CONTR! 1 )=CONTR(d) 

1 1770002 

Ol-RIN!  1  )=DLRIN(d) 

11780002 

DLROUT ( 1 )=DLROUT(d) 

1 1790002 

ACNTRT ( 1 )=ACNTRT(d) 

11800002 

BCNTRT! 1 )=BCNTRT(d) 

11810002 

OCNTRT ( 1 )=OCNTRT(d) 

1 1820002 

OALIIN! 1)=0ALIIN(d) 

11830002 

OALIRE!  1  )=OALIRE(d) 

1 1840002 

AONHND! 1 )=AONHND(d) 

11850002 

BONHND! 1 )=BONHND(d) 

1 1860002 

OONHND! 1 )=OOMHND(d) 

1 1870002 

DLROH! 1 )=DLROH(d) 

1 1880002 

NODR! 1 )=NODR(d) 

1 1890002 

] 

PVINP! 1 )=PVINP(d) 

1 1900002 

PEELN0! 1 )=PEELMD!d) 

1 10 10002 

OAR!  1)=0AR(d") 

1 1920034 

NOAR( 1 )=NOAR(d) 

1 1930002 

OPER! 1 )=OPER(d) 

1 1940002 

ISTRAT! 1 ) = I STRAT ( d ) 

1  1950002 

IPEER! 1 )=IPEER! d) 

1 1960053 

J 

WMDR! 1 )=WMDR(d) 

1 1970002 

1 

DAYSCL! 1 )=DAYSCL(d) 

1 1980002 

5 

ISEO( 1)=ISE0(d) 

11990002 

' 

RECS! 1 )=RECS(d) 

12000002 

IPRNT! 1 )=IPRNT(d) 

12020042 

' 

RETURN 

12030002 
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12040002 

12050002 


THIS  SUBROUTINE  COMPUTES  ATTRIBUTE  VALUES  AND  RATES  PRIOR  TO  12060002 

TOPSIS  PROCESSING.  12070002 

12080002 

SUBROUT  I NE  PREP IN( KA . AODR . BOOR . CODR . DOOR , EODR . WD . ECP , MRB . EPA . DE VN, 1 2090099 
1WMDR . TOPCA , CAR ATE , WDRATE , ECPRAT . AMRBRA . EPARAT . DEVNRA , WMDRRA .  1 2 10C099 

2SI ARTM, ST  ARTY . ENDMO , ENDYR . FSCM. MONTH, YEAR , TOPWD , TOPECP , TOPMRB ,  121 10002 

3T0PEPA , TOPDEV , TOPMDR . DCASR , QAORG .DEGREE . AIDEAL , AWORST .BIDEAL .  121 20099 

4BW0RST . ISTRAT . WEIGHT , REINHR , INTHR . MTGHR , SHIPMT , LOT INS .VISIT , PVN,  12130002 
5TYP . PEHR . CONTR . PLANHR . DAYSCL . PCQ . CAO . NODR , SI . ADMNHR , PVINP ,  12140094 

6PEELNP .QAL IIN.OALIRE. LONG , TOPSCR , PVIHR , QNHAND , OAR , IPRNT ,  12150099 

7 IPEER .CMDT Y , NOAR )  12160099 

INTEGER  AODRI 120) ,BQDR( 120) ,CODR( 120) ,DQDR( 1 20). EODR ( 120) . WD( 120) . 12170002 
1ECP( 120) ,MRB( 120) . STARTM, START Y. ENDMO, ENDYR, M0NTH( 120) . YEAR ( 120) .  12180002 
2 1 MONTH ( 120) , IYEAR( 120) ,DEGREE( 120) , IDGREE( 120) , ISTRAT( 120) .  12190002 

3 JSTRAT ( 120) ,REINHR( 120) . INTHR( 120) ,MTGHR( 120) ,SHIPMT( 120) .  12200002 

4L0T INS ( 120) .VISIT ( 120) ,PEHR( 120) .CONTR ( 120). PLANHR ( 120).  12210002 

SDAYSCH 120) ,PCO( 120) ,CAO( 120) , NODR ( 120) . ADMNHR( 120) , PVINP( 120) .  12220002 

6PEELNP1 120) ,OALIIN( 120) . QAL I  RE ( 120) ,FLAGA(  120)  12230099 

INTEGER  FLAGB( 120) . FLAGC1 ( 120) , FLAGC2( 120) . FLAGC3( 120) . FLAGC4 ( 120) 12240002 
1 ,FLAGC5( 120) ,FLAGD( 120) ,FLAGEF( 120) ,FLAGE( 120) ,FLAGF( 120) .  12250002 

2FLAGG2( 120) ,FLAGH1( 120) ,FLAGH2( 120) ,FLAGJ(  120) , FLAGK1 ( 120)  12260002 

INTEGER  FLAGK2( 120) , FLAGL( 120) . FLAGN( 120) , FLAGO( 120) . FLAGP( 120) .  12270002 

1 FLAGO 1 ( 120) ,FLAG03( 120) ,FCOUNT( 120) .FLAGE 1( 120).  12280099 

2PVIHR( 120) . ONHAND( 120) . IPRNT( 120) . I  PEER! 120) . JPEERt 120) ,NOAR( 120)  12290099 
CHARACTER  FSCM( 120) '6 . DCASR( 120 ) *6 , 0A0RG( 1 20) *  3 ,DCASCD( 120)*6.  12300002 

10RGCD( 120) *  3 . PVN( 120)‘ 1 ,TYP( 120) *  1 . FLAGF 1 ( 120) *  1 . FLAGG  1 (  120)* 1 .  12310002 

2FLAG( 120)* 18 , TP( 120)'1 ,OAR( 120 ) *5 , CMDTY ( 120) *2 . BFSCM( 2000) *5  12320099 

REAL  WMDR( 120) . S I  (  120) . EPA( 120) ,DEVN( 120) ,T0PCA( 120) . CARATE (  120) .  12330099 
1 WDRATE ( 120) .ECPRAT ( 120) .AMRBRA ( 120),EPARAT( 120) .DEVNRA ( 120) .  12340099 

2WMDRRA (  120)  ,TOPEPA(  120 )  .  TOPDF.Vf  120)  ,T0PMRB(  120)  ,TOPECP(  120)  .  12350099 

3T0PWD( 120) .TOPMDR ( 120) . A( 999 , 38 ) . T0PSCR( 14, 120) , AIDEAL( 4 , 7 ) .  12360099 

4 AWORST (4. 7 ) ,BIDEAL(4,7) ,BW0RST(4,7) .WEIGHT (7) . FLAGM( 120)  12370094 

COMMON  /RVAR/A  12380002 

COMMON  / CHTR/BFSCM , FLAG  12390002 

INITIALIZE  ARRAYS.  ATTRIBUTE  OEFAULT  VALUES  ARE  0.0.  RATE  DEFAULT  12400002 
VALUES  ARE  0.0.  12410002 

DO  5  1=1,120  12420002 

TOPCA( I ) =0 . 0  12430002 

CARATE ( I ) =0.0  12440002 

TOPEPA ( I ) =0 . 0  12450002 

EPARAT ( I ) =0 .0  12460002 

TOPDkV ( I  ) =0.0  12470099 

DEVNRAU )=0.0  12480099 

TOPMRB ( I ) =0 . 0  12490002 

AMRBRA ( I ) =0 . 0  12500002 

TOPECP (I  )  =0.0  12510002 

ECPRAT (I ) =0.0  12520002 

TOPWD( I ) =0 . 0  12530002 

WDRATEd  )=0.0  12540002 

TOPMDR ( I ) =0 .0  12550002 

WMDRRA ( I ) =0 .0  12560002 

5  CONTINUE  12570002 

COMPUTE  THE  NUMBER  OF  MONTHS  TOPSIS  WILL  PROCESS.  12580002 

MON= (ENDYR- ST ARTY )* 12  +  ENDMO  -  STARTM  +  1  12590002 

1 F ( ( YE  AR ( KA )  LT .  ENDYR)  .OR.  ((YEAR(KA)  .EQ.  ENDYR)  .AND.  12600002 

1  (MONTH(KA)  .LT.  ENDMO)))  MON=MON- ( ( ENDYR  -  YE  AR  ( KA  ) )  •  12  t-ENDMO-  12610002 

2M0NTH1 KA ) )  12620002 

IF  (MON  .GE.  KA)  GOTO  30  ■  12630002 

DO  10  1=1, MON  12640002 

*»**  COMPUTE  RATES  FOR  ATTRIBUTES . RATES  RANGE  FROM  -3  TO  +3.  12650002 

RATE  IS  COMPUTED  BY  TAKING  RATIO  OF  FIRST  HALF  TO  SECOND  HALF  12660002 

OF  DATA  ARRAY.  RATES  OF  0  TO  3  ARE  INCREASES.  12670002 

INITIALIZE  INTERNAL  PARAMETERS  12680002 

IPRICA=0  12690002 

I AFTCA=0  12700002 

PRIEPA=0.0  12710002 

AFTEPA=0 . 0  12720002 

I PRIMR=0  12730002 

I AFTMR=0  12740002 

IPRIWD=0  12750002 

I AFTWD=0  12760002 

PRIDEV=G . 0  12770099 

AFTDEV=0 .0  12780099 

IPRIEC=0  12790002 

I AFTEC=0  12800002 

PRIMDR=0 . 0  12B10002 

AFTMDR=0 . 0  12820002 

IF  THERE  IS  MORE  THAN  6  MONTHS  OF  DATA.  MODEL  IGNORES  PRIOR  12830045 


o  o 


C  OATA  WHEN  COMPUTING  RATES. 

dMON=MON-l 
KC=KA-UMON 
IF ( KC  .GT.  6)  GOTO  7 

C  IF(KC  .GT . 12)  GOTO  7 

IOFFST= 1 
GO  TO  G 

7  IOFFST  =KC- 1 1 

KC  =  12 

7  IOFFST  =KC-5 

KC=G 

6  MIDMON=(KC  +  1 )/2 

IF  (MIDMON-2  .EO.  (KC  +1))  GOTO  22 
C  EVEN  NUMBER  OF  OATA  POINTS 

I NDMO=MIDMON+ IOFFST- 1 
GO  TO  21 

C  ODD  NUMBER  OF  DATA  POINTS 
22  I NDMO=MIDMON+ IOFFST-2 
21  DO  24  d= IOFFST . INDMO 
K=MIOMON  *  d 

C  THE  NEXT  TWO  LINES  REFLECT  POLICY  CHANGE  UNDER  IOUE 
C  CARS  ARE  REPORTED  AS  COMBINED  VERBAL  AND  WRITTEN  VS  TYPE  A  +  B 
C  MUST  BE  CAREFUL  HERE  . 

IPRICA=IPRICA+( ( AQDR(d)+BODR(d) )"7.5+CQDR( J ) * 30+DQDRI d ) '60 
1+EQDR( d ) *30) 

I AFTCA= I AFTCA+( ( AODR ( K ) +BODR( K ) ) »7 . 5+CQDR (K ) '30+DQDR ( K ) *60 
1+E0DR( K ) *30) 

PRI EPA  =  PRI EPA+EPA ( d ) 

AFTEPA=AFTEPA+EPA(K) 

I  PR  I MR = I PRIMR+MRB ( d ) 

I AFTMR= I AFTMR+MRB(K ) 

I  PR  I WD= I PRI WD+WD( d ) 

I AFTWD= I AFTWD+WD(K ) 

PRIDEV=PR7DEV+DEVN( d) 

AFTDEV=AFTDEV+DEVN(K) 

IPRIEC=IPRIEC+ECP(d) 

IAFTEC=IAFTEC+ECP(K) 

PRIMDR=PRIMDR+WMDR(d) 

AFTMDR=AFTMDR+WMDR( K ) 

24  CONTINUE 

L=KA-MON+I 

C  COMPUTE  ATTRIBUTE  VALUES. 

TOPCAd )=(A0DR(L)^B0DR(L))*7.5+C0DR(L)*3O+D0DR(L)*6O+E0DR(L)»3O 
TOPEPA(I  )  =  EPA(L) 

TOPMRB( I ) =MRB( L ) 

TOPWD(I )=WD(L) 

TOPDEV( I )=DEVN(L) 

TOPECP(I  )  =  ECP(L) 

TOPMDRd  )  =WMDR(  L  ) 

C  RATE  IS  A  VALUE  BETWEEN  -3  AND  -*3 

C  IF  SECOND  HALF  IS  NEGLIGIBLE  OR  ZERO.  RATE  IS  -3  OR  0  DEPENDING  ON 
C  FIRST  HALF  ACTIVITY. 

C  RATE  IS  SET  TO  -3.0  WHEN  THERE  IS  NO  HISTORY  WHATSOEVER  OF  INDICATOR 
C  THIS  WAS  DECIDED  AT  SAG  U 5  AND  DOCUMENTED  VIA  MFR  22N0V  88. 

C 

26  CARAT E ( I)  =  (REAL(IPRICA))/(REAL(IAFTCA)+.  1  )*3.0 

I F (CARATE ( I  )  .GT.  6.0)  CARATE(I)=6.0 
IF( (IPRICA+IAFTCA)  .EO.  0)  CARATE(I)=6.0 
CARATE(I ) =3 . 0-CARATE ( I  ) 

EPARAT (I )=PRIEPA/(AFTEPA+.01 ) *2.0 
IF ( EPARAT ( I  )  .GT.  6.0)  EOARAT(I)=6.0 
IFdPRIEPA+AFTEPA)  .EO.  0.0)  EPARAT(I)=6.0 
EPARAT(I )  =  3 . 0- EPARAT ( I ) 

AMRBRAf I )  =  ( REAL ( IPRIMR ) )/( REAL (I AFTMR)+ . 01 )*3 .0 
I F ( AMRBRA ( I )  .GT.  6.0)  AMRBRA(I)=6.0 
I F ( ( IPRIMR+I AFTMR )  .EO.  0)  AMRBRA(I)=6.0 
AMRBRA (I ) =3 . 0- AMRBRA ( I ) 

WDRATEd  )=(REAL(IPRIWD))/(REALdAFTWD)+.01)*3  O 
IF(WDRATE(I)  .GT.  6.0)  WDRATE(I)=6.0 
I F ( ( IPRIWD+I AFTWD )  .EO.  0)  WDRATE(I)=6.0 
WDRATE ( I ) =3 . O-WDRATE ( I ) 

DEVNRA(I )=PRIDEV/(AFTDEV+ .01 )*3.0 
IF(DEVNRA(I)  .GT.  6.0)  DEVNRA(I)=6.0 
IFUPRIDEV+AFTDEV)  .EO.  0.0)  DEVNRA(  I  )=6 .0 
DEVNRA( I ) =3 .0-DEVNRA(  I ) 

ECPRAT(I )=(REAL(IPRIEC))/(REAL(IAFTEC)+.01)*3.0 
I F ( ECPRAT ( I )  .GT.  6.0)  ECPRAT(1)=6.0 
IF((IPRIEC+IAFTEC)  .EO.  0)  ECPRAT ( I )=6 .0 
ECPRAT ( I )=3 .O-ECPRAT ( I ) 

WMDRRAf I ) =PRIMDR/ ( AFTMDR+ .01 ) *3 .0 
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12870045 
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13310002 

13320002 
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13370023 
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13600002 

13610023 

13620002 

13630002 
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IF(WMDRRAd)  .GT.  6.0)  WMDRRA(I)=6.0  13640002 

I F( ( PRIMDR+AFTMDR )  .EO.  0.0)  WMDRRA{ I ) =6 .0  13650023 

WMDRRAd )=3.0-WMDRRA(I)  13660002 

C  SHIFT  OTHER  VARIABLES  TO  THE  NEW  TIME  FRAME  13670002 

CALL  SHIFTRd .L, DCASCD . DCASR , ORGCD .QAORG , IMONTH, MONTH. I  YEAR, YEAR,  13680002 
1 1DGREE . DEGREE . JSTRAT . ISTRAT , FLAGA . REINHR , FLAGB , INTHR . FLAGD.MTGHR ,  1 3620002 
2FLAGEF , SHI PMT . FLAGE . LOT I NS . FLAGF . VISIT , FLAGF 1 , TYP , TP , FLAGG1 , PVN ,  13700002 
3FLAGG2 . PEHR , FLAGH1 , CONTR , FLAGH2 , PLANHR . FLAGJ, DAYSCL , FLAGK 1 , OALI IN. 13710002 
4FLAGK2 .OALIRE , FLAGL ,NOOR, FLAGM. SI . FLAGN, PCO. FLAGO . CAO , FLAGP ,  13720092 

5A0MNHR , FLAGO 1 , PVINP , FLAG03 . PEELNP , FLAGC 1 , AQDR .  1 3730099 

6FLAGC2 , BOOR , FLAGC3 . CODR . FLAGC4 .DOOR . FLAGC5 . EQDR .FLAGE 1 . PVIHR .  13740026 

70NHAND , OAR . IPRNT , I  PEER , JPEER .CMDTY ,NQAR )  13750099 

C  COMPUTE  TOPSIS  SCORES  13760002 

CALL  TOPSI S( I . IDGREE , TOPCA , CARATE . TOPEPA , EPARAT , TOPMRB , AMRBRA ,  13770002 

1T0PWD . WDRATE . TOPOEV , DEVNRA . TOPECP , ECPRAT , TOPMDR . WMDRRA , TOPSCR ,  1 3780099 

2AI0EAL. AWORST, BIDEAL, BWORST . JPEER. WEIGHT. LOTINS)  13790092 

C  IDENTIFY  RED  FLAG  CONDITIONS  13800002 

CALL  FLGGR ( I .FLAGA , TOPCA . FLAGB , FLAGC 1 , FLAGC2 , FLAGC3 , FLAGC4 .  138 10002 

1FLAGC5 . FLAGO . FLAGEF .FLAGE , FLAGE 1 .  13820002 

2FLAGF , FLAGF 1 , FLAGG1 , FLAGG2 , FLAGH1 . FLAGH2 , TOPDEV,  13830099 

3FLAGJ, FLAGK 1 . FLAGK2 .ONHANO , FLAGL . FLAGM. FLAGN. FLAGO , FLAGP .  13840026 

4FLAG01 .FLAG02.FC0UNT. JPEER. TOPEPA)  13850099 

CALL  SCORERd .FCOUNT. TOPSCR, TP. JSTRAT)  13860002 

C  WRITE  RECORO  TO  VERIFY  PROGRAM  13870002 

IF  (LONG  .EO.  0)  GOTO  50  13880002 

WRITE  (9. 25)  I  .OCASCOd  )  ,ORGCD(  I  )  ,FSCM(  1 )  .  IMONTHd  ) .  I  YEARd  ) .  13890002 

Idf  EER(  I  ) ,  IDGREEd  )  ,TOPEPA(  I  ),EPARAT(  I  ),TOPDEV(I )  .  DEVNRA  ( I  ) .  13900099 

2T0PMRB( I ) , AMRBRA ( I ) ,TOPWD( I ). WDRATE (I ), TOPECP (I ) .  13910060 

3ECPRAT ( I ) , TOPCA(I ) , CARATE ( I ) , TOPMDR( I ) , WMDRRA (I ) .  1 3920060 

4T0PSCR ( 1 . I ) ,T0PSCR(2, I ) . TOPSCR( 3 . I ) . TOPSCR ( 4 . I ) .TOPSCR (5, I ) .  13930002 

5T0PSCR( 6 . I ) .TOPSCR (7. I ) . TOPSCR ( 8 , I ) , TOPSCR ( 9 , I ) ,TOPSCR( 10. I) .  13940002 

6T0PSCR (  11,1 ) . FLAG( I ) ,FCOUNT(I )  13950002 

25  T1RMAT (I3.A6,A3,A6,2I3,I4,I2,2(F6.2,F5.2),4(F4.0,F5.2),F4.2,F5.2, 13960099 
11  .  j.1 .A  18, 12)  13970099 

50  I F ( ( I  YEAR ( I )  .LT.  STARTY)  .OR.  ((IYEAR(I)  .EO.  STARTY)  .AND.  13980002 

1 (IMONTH(I)  . LT .  STARTM)))  GOTO  10  13990002 

WRITE ( 11.51)  ORGCD ( I ) , FSCM( 1 ) , TP (I ) , CMDTY ( I ) , PVN( I ) . NOAR ( I ) ,  14000099 

1 IMONTH(I),  14010099 

21 YEAR( I  )  .JSTRAT (I ) . JPEER( 1 ) , IDGREE ( I ) ,QAR( I ) , FLAG( I ) . TOPSCR( 10.1), 14020099 
3T0PSCR ( 1 . 1  )  ,TOPSCR( 2 , 1 ) ,T0PSCR(3. 1 ) . T0PSCR14 . 1 ) . TOPSCR( 5 , I ) .  14030099 

4T0PSCR(6, I ).T0PSCR(7.I) ,T0PSCR(8, I ) , TOPSCR ( 11.1) , TOPSCR ( 12.1),  1404C099 

5T0PSCR (13,1).  TOPSCR (■'4,1).  STARTM.  STARTY .  ENDMO ,  ENDYR .  I  1 4050099 

51  FORMAT (A3.A6.A1,A2,A1,3I3,2I4,I2,A5,A18,13F7.1,5I2)  14060099 

10  CONTINUE  14070002 

GO  TO  40  14080002 

30  WRITE  (6,35)  FSCM( 1 ) . KA . MON  14090002 

35  F0RMAT(2X, 'WARNING.  INSUFFICIENT  DATA  FOR  FSCM' , A6 . 213 .  14100002 

1'FSCM  SKIPPED  BUT  DATA  ON  THE  LABEL  FILE')  14110002 

40  RETURN  14120002 

END  14130002 

SUBROUTINE  TOPSI sf I , IDGREE . TOPCA . CARATE , TOPEPA , EPARAT . TOPMRB .  14140002 

1 AMRBRA . TOPWD . WDRATE . TOPDEV , DEVNRA , TOPECP . ECPRAT , TOPMDR , WMDRRA ,  141 50099 

2T0PSCR. AI DEAL. AWORST, BIDEAL, BWORST. JPEER, WEIGHT, LOTINS)  14160092 

REAL  A (999. 38) ,TOPCA( 120) .CARATE ( 120) .TOPEPA ( 1 20), EPARAT ( 120) ,  14170052 

1 TOPMRB ( 120) ,AMRBRA( 120) ,TOPWD( 1 20) , WDRATE ( 1 20) . TOPDEV( 120) ,  14180099 

201 VNRA ( 120) .TOPECPf 120) .ECPRAT( 120) ,TOPMDR( 120) , WMDRRA ( 120) .  14190099 

3 TOPSCR ( 14. 120).AI DEAL (4.7), AWORST (4.7). BIDEAL (4,7), BWORST (4.7).  14200099 

42(7  )  ,SPLUS(7) . SMINUSd ) ,WLIGHT<7)  142 10092 

INTEGER  IDGREE ( 120) , JPEER ( 120) , LOT  I NS ( 120)  14220060 

COMMON  /RVAR/A  14230002 

TOPSCR( 8 , I ) =0 .0  14240002 

UTSUM=0.0  14250002 

SP0S=0.0  14260002 

SNEG=0.0  14270002 

C  COMPUTE  Z  VALUES  FOR  NONRATE  PARAMETERS  14280002 

C  NEXT  LINES  ASSUME  EXPONENTIAL  DISTRIBUTION  14290002 

Z( 1  )=LOG(TOPEPA(I )/ ( A ( JPEER (I ), 13)+. 0001 )+. 00001)  14300060 

Z( 2 )= LOG ( TOPDEV ( I )/(A( JPEER (I ) , 15)+. 0001 )+. 00001 )  14310099 

Z( 3  )  =  LOG ( TOPMRB ( I )/(A( JPEERd ).7)+ .0001 )+. 00001 )  14320060 

Z( 4 )= LOG ( TOPWD ( I )/( A( JPEER (I ) , 3 )+ . 000 1 )+ . 00001 )  14330060 

Z( 5 )=LOG (TOPECP ( I )/( A( JPEER( I ) ,5)+ .0001 )+. 00001 )  14340060 

2(6 )= LOG (TOPCA ( I )/( A( JPEER(I ) , 29)+ .0001 )+. 00001 )  14350060 

2(7 )=LOG( TOPMDR ( I)/(A(JPEER(I). 35)+ .0001 )+. 00001)  14360060 

C  ASSIGN  LIMITS  TO  Z  VALUES  FOR  OUTLIERS. Z  MUST  BE  BETWEEN  -3.0  AND  3.0  14370032 
DO  1  J=1 ,7  14380002 

I F ( Z ( J )  .LT.  -3.0)  Z( J) =-3 .0  14390002 

I F ( Z ( J  )  .GT.  3.0)  Z(d)=3.0  14400002 

1  CONTINUE  14410002 

C  COMPUTE  TOPSIS  SEPARATION  MEASURES  FROM  NEGATIVE  IDEAL  14420002 

SMINUSf  1 )  ‘-BWORST  (  IDGREE  ( I  )  .  1  )-EPARAT(I  )  14430002 
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SMINUS ( 2 ) =BWORST( IDGREE ( I ) . 2 ) -DEVNRA ( I ) 

SMINUS! 3 ) =BWORS  r( IDGREE ( I ) .3 )-AMRBRA( I ) 

SMINUS( 4 ) =BWORST ( IDGREE ( I ) , 4 J-WDRATE ( I  ) 

SMINUS ( 5 )=BWORST ( IDGREE( I ) , 5 )-ECPRAT ( I  ) 

SMINUS ( 6 ) =BWORST ( IDGREE ( I ) . 6 ) -CARATE ( I ) 

SMINUS (7 )=BWORST( IDGREE ( I ) , 7 )-WMDRRA( I ) 

C  IF  CONTRACTOR  IS  A  PROBLEM,  INCREASE  WEIGHT  OF  TREND  TO  60/40  EXC  PQDR 
I F ( ( IDGREE ( I )  .EQ.  1)  -OR.  (IDGREE(I)  .EQ.  3))  THEN 
DO  3  0=1.6 

SMINUS( 0 ) =SMINUS( 0 )  ' 1 . 5 

3  CONTINUE 

SMINUS! 7 ) = AWORST ( IDGREE( I ) , 7 ) -2( 7 ) 

END  IF 

00  2  0=1.7 

C  SMINUS(d)=SQRT(SMINUS(d)"2+(AW0RST(IDGREE(I), d)-Z(J))**2) 

C  BELOW  LINE  REFLECTS  'CITY  BLOCK'  DISTANCE.  ABOVE  IS  EUCLIDIAN 
C  CITY  BLOCK  SEEMS  TO  WORK  BETTER  FOR  NONRESIDENT. 

SMINUS(d)=SMINUS(d)+(AWORST( IDGREE (I ).d)-Z(d) ) 

2  CONTINUE 

C  COMPUTE  10PSIS  SEPARATION  MEASURES  FROM  POSITIVE  IDEAL 
SPLUS!  1 ) “EPARAI ( I  (-BIOEAL! IOGREE! 1 )  .  1 ) 

SPLUS(2)=DEVNRA( I ) -B IDEAL ( IDGREE(I) ,2) 

SPLUSI 3 ) =AMRBRA( I)-BIDEAL(IDGREE(I),3) 

SPLUS(4)=WDRATE(I ) -B IDEAL{ IDGREE ( I ) ,4) 

SPLUSI 5 )=ECPRAT{ I )-BIDEAL( IDGREE! I ) , 5) 
SPLUS(6)=CARATE(I)-BI0EAL(IDGREE(I ) ,6) 

SPLUSI 7 )=WMDRRA( I  ) -B IDEAL  I IDGREE 1 1 ), 7 ) 

I F I ( IDGREE! I )  .EQ.  1)  .OR.  ( IDGREE! I )  .EQ.  3))  THEN 
DO  4  d=1 ,6 

SPLUS(d)=SPLUS(d)* 1 .5 

4  CONTINUE 

SPLUS(7)=Z(7)-AID£AL( IDGREE ( I ) , 7 ) 

ENDIF 

DO  7  0=1.7 

C  SPLUS! d)=SQRT( SPLUS! d)"2+(2(d)-AIDEAL( IDGREE (I ).d))"-2) 

C  BELOW  LINE  REFLECTS  'CITY  BLOCK'  DISTANCE.  ABOVE  IS  EUCLIDIAN 
C  CITY  BLOCK  SEEMS  TO  WORK  BETTER  FOR  NONRESIDENT. 

SPLUS! d)=SPLUS(0)+( Z(d)-AIDEAL( IDGREE! I ) , 0 ) ) 

7  CONTINUE 

C  COMBINE  DISTANCES  INTO  AN  OVERALL  TOPSIS  SCORE 
DO  9  0=1.7 

WTSUM=WTSUM+WE IGHT ( 0 ) 

SNEG=SNEG+( SMINUS! 0 ) ‘WEIGHT ( 0) ) **2 
SP0S=SP0S+< SPLUS! 0) 'WEIGHT! d))**2 

TOPSCR( 0 , I )=SMINUS!d)/(SPLUS(d)+SMINUS(d)+.00001)'100 
TOPSCRO.  I  )=  TOPSCR (8.1  )+T0PSCR(d,  I  ) ‘WEIGHT (0) 

9  CONTINUE 

TOPSCR ( 9 . 1  )  =  SORT ( SNEG ) / ( SORT ( SNEG )+SQRT ( SPOS ) ) ' 100 
TOPSCR! 8 . I )=T0PSCR(8, I I/WTSUM 
C  COMPUTE  A  MODIFIED  SCORE  BASED  ON  DEGREE  OF  DIFFICULTY 
CALL  LIMITR! I . IDGREE .TOPSCR) 

RETURN 
END 

*»*  DEFINES  IDEAL  AND  NEGATIVE  IDEAL  CONDITIONS  FOR  EACH  DIFFICULTY 
ALSO  DETERMINES  WEIGHT  FACTORS  FOR  EACH  SITUATION 

SUBROUTINE  CORNER! AIDEAL . AWORST .BIDEAL, BWORST , WEIGHT ) 

REAL  AIDEAL (4 .7) . AWORST! 4, 7) ,B IDEAL (4, 7) .BWORST (4, 7) .WEIGHT! 7 ) 

C  DEFINE  IDEAL  AND  NEGATIVE  IOEALS 

C  0=1  -  PA. 0=2  -DEVN.d=3  -  MRB.d=4  -WVR,d=5  -  ECP.d=6  -CAR. 0=7  -PQDR 
C  K  IS  DIFFICULTY  INDEX 

C  THESE  ARE  QUEST  III  WEIGHTS  FROM  17-19  OUL  90  SAG. 

C  WEIGHTS  MUST  ADD  TO  1.00 
WEIGHT! 1 )= . 168 
WEIGHT(2)= .074 
WEIGHT ( 3 ) = . 148 
WEIGHT ( 4 ) = . 151 
WEIGHT(5)= .064 
WEIGHT ( 6 ) = . 198 
WEIGHT ( 7 ) = . 197 
DO  1  K= 1 , 4 
DO  2  0=1.7 
AIDEAL(K.d)=-3.0 
AWORST ( K , d )=3 .0 
BIDEAL(K,d)="3.0 
BWORST ( K , d)=3 . 0 
2  CONTINUE 

IF! (K  .EQ.  1)  .OR.  (K  .EQ.  3))  THEN 
BIDEAL(K,7)-0.0 


14440099 
14450002 
14460002 
14470002 
14480002 
14490002 
14500099 
14510002 
14520099 
14530099 
14540099 
14550002 
14560099 
14570002 
14580033 
14590002 
14600002 
14610033 
14620002 
14630002 
14640002 
14650099 
14660002 
14670002 
14680002 
14690002 
1470C002 
14710002 
14720099 
14730099 
14740099 
14750002 
14760099 
14770002 
14780033 
14790002 
14800002 
14810033 
14820002 
14830002 
14840002 
14850086 
14860086 
14870086 
14880086 
14B90086 
14900002 
14910002 
14920002 
14930002 
14940023 
14950002 
14960002 
14970002 
14980002 
14990002 
15000002 
1501 0002 
15020022 
15030002 
15040099 
15050002 
15060099 
15070099 
15080099 
15090099 
15100099 
15110099 
15120099 
15130099 
15140099 
15150002 
15160002 
15170002 
15180002 
15190002 
15200002 
15210002 
15220002 
15230002 
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BWORST ( K , 7 ) =0 . 0 
END  IF 

C  DO  5  JM,7 

C  WRITE(6.  10)  K,<J,AIDEAL(K,<J)  ,  AWORST(K , J)  ,BIDEAL(K,J),  BWORST  (K ,  U ) 

C  10  FORMAT ( 2I2.5F10.2) 

C  5  CONTINUE 

1  CONTINUE 

WRITE (6. 12)  WEIGHT ( 1 ) . WEIGHT! 2 ) . WEIGHT! 3 ) . WEIGHT (4 ) , 

1WE I GHT ( 5 ) .WEIGHT ( 6 ) , WEIGHT( 7 ) 

12  FORMAT (/ , 7F 10.3) 

RETURN 

END 

C 

C  THIS  SUBROUTINE  ESTABLISHES  ARBITRARY  LIMITS  ON  TOPSIS  SCORES 
C  A  KNOB  FOR  PROBLEM  FACILITIES  IS  SET  TO  MAX  PRODUCT  SCORES  AT  79% 

C  A  KNOB  FOR  PROBLEM  FACILITIES  IS  REMOVED. 

•A  C 

SUBROUTINE  LIMITR( I . IDGREE .TOPSCR ) 

REAL  TOPSCR( 14. 120) 

INTEGER  IDGR£E( 120) 

.  COMMON  /RVAR/A 

DO  2  U=8 , 9 

IF  ( ( IDGREE ( I )  .EQ.  1)  .OR.  ( IDGREE ( I )  .EQ.  3))  TOPSCR(U.I)* 
1T0PSCR( J , I ) *  1 .00 

2  CONTINUE 
RETURN 
END 

C 

C  THIS  SUBROUTINE  LINKS  HISTORY  ARRAYS  WITH  MODEL  ARRAYS 
C 

SUBROUT  1 NE  SHI FTR ( I , L . DCASCD , DCASR , ORGCD . OAORG . I MNTH . MNTH . I YR . YR , 

1 IDGREE . DEGREE . JSTRAT . ISTRAT . FLAGA . RE INHR . FLAGB . INTHR . FLAGD.MTGHR . 
2FIAGEF.SHIPMT.FLAGE.L0TINS.FLAGF.VISIT.FLAGF1.TYP.TP.FLAGG1.PVN, 
3FLAGG2 . PEHR . FLAGH 1 . CONTR . FLAGH2 . PLANHR . FLAGU , DA YSCL . FLAGK 1 . QAL  UN. 
4rLAGK2.0ALIRE.FLAGL.N0DR.FLAGM.SI . FLAGN , PCO , FLAGO . CAO . F LAGP . 
SADMNHR . FLAG0 1 . PV I NP , F  LAG03 . PE  ELNP . FLAGC 1 , AODR , 

6FLAGC2 . BODR . FLAGC3 . CODR . FLAGC4 . DODR . FLAGC5 . EODR . FLAGE 1 . PVIHR . 
70NHAND.0AR. IPRNT, I  PEER . UPEER . CMDTY , NOAR ) 

INTEGER  MNTH( 120) . YR( 120) . AQDR( 120) ,BODR( 120) ,CODR( 120) ,DODR( 120) . 
1 1 MNTH( 120) . IYR( 120) .OEGREE( 120) , IDGREE{ 120) , ISTRAT( 120) , 

2J5TRAT ( 120) . REINHR( 120).INTHR( 120),MTGHR( 120),SHIPMT( 120), 

3L0TINS( 120) . VISIT( 120) ,PEHR( 120) .CONTR( 120) ,PLANHR( 120) . 

4DA YSCL ( 120) ,PCO( 120) .CAO( 120) ,NODR( 120) . ADMNHR( 120) . PVINP( 120) . 
5PEELNP( 120) ,OALI IN( 120) . OALIRE ( 1 20) , FLAGA ( 120) . 

6FLAGB! 120) . FLAGD( 120) ,FLAGEF( 120) ,FLAGE( 120) , FLAGF ( 1 20) , 

7FLAGG2( 120) ,FLAGH1( 120) ,FLAGH2( 120),FLAGd( 120) . FLAGK 1 ( 120) . 
8FLAGK2( 120) ,FLAGL( 120) ,FLAGN( 120),FLAGO( 120) .FLAGP( 120) . 

9FLAG01 ( 120) , FLAGQ3( 120) .EODR ( 12) . FLAGC 1( 120) ,NQAR( 120) 

INTEGER  FLAGC2( 120) . FLAGC3( 120) . FLAGC4( 120) , FLAGC5( 120) . 

1 FLAGE 1( 120) .PVIHR ( 120) .ONHANO! 120),IPRNT( 120).IPEER( 120) . 

2UPEER( 120) 

CHARACTER  9CASR( 1 20) * 6 . OAORG( 1 20 ) *3 , DCASCD( 120)*6,TP( 120)* 1 , 
10RGCD! 120) ’ 3 . PVN( 120) *1 ,TYP( 120) *  1 . FLAGF 1 ( 120) *  1 . FLAGG1 ( 120) *  1 , 
2QAR( 120) *5 , CMDTY ( 120)*2 
REAL  S I ( 120), FLAGM( 120) 

DCASCD( I ) =DCASR( L ) 

CMDTY ( I ) =CMDTY ( L ) 

PVN( I ) =PVN( L  ) 

ORGCDd )=OAORG(L) 

IMNTH1I )=MNTH(L) 

I  YRd  )  =  YR(  L  ) 

IDGREE ( I ) 'DEGREE  (  L ) 

OAR( I )=OAR(L) 

NQAR( I )=NOAR(L) 

USTRAT(I)=ISTRAT(L) 

UPEERd  )  =  IPEER(L) 

TP( I ) =TYP( L ) 

I PRNT ( I ) = I PRNT ( L ) 

FLAGAtl ) =REINHR( L ) 

FLAGS'  I )-INTHR(L) 

FLAGC 1(1) = AODR ( L ) 

FLAGC2( I )=BODR(L) 

FLAGC3( I ) =CQDR<  L ) 

FLAGC4(I)=D0DR(L) 

FLAGC5I I )=EQDR( L) 

FLAGD  =MTGHR(L) 

FLAGEF! I ) =SHIPMT ( L ) 

FLAGEd  )  =  LOTINS(  L ) 

FLAGE 1(I)=PVIHR(L) 

FLAGF (I)=VISIT(L) 
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15240002 
15250002 
15260099 
15270099 
15280099 
15290099 
15300099 
15310099 
15320099 
15330099 
15340002 
15350002 
15360002 
15370002 
15380023 
15390099 
15400023 
15410023 
15420099 
15430002 
15140002 
15450002 
15460002 
15470099 
15480002 
15490023 
15500002 
15510002 
15520002 
15530002 
15540002 
15550002 
15560002 
15570002 
15580092 
15590099 
15600026 
15610099 
15620002 
15630002 
15640002 
15650002 
15660002 
15670099 
15680002 
15690002 
15700002 
157 10099 
15720002 
15730061 
15740061 
15750002 
15760034 
15770099 
15780092 
15790002 
15800095 
15810095 
15820002 
15830002 
15840002 
15850002 
15860034 
15870099 
15880002 
15890060 
15900002 
15910042 

15920002 

* 

« 

15940002 

15950002 

15960002 

15970002 

15980002 

15990002 

16000002 

16010002 

16020002 

16030002 


FLAGF 1 ( I )=TYP( L ) 

FLAGG1 ( I )=PVN( L ) 

FLAGG2(I)=PEHR(L) 

FLAGH1 ( I ) =CONTR(L ) 

FLAGH2 ( I ) =PLANHR( L ) 

FLAGJ( I )=DAYSCL( L ) 

FLAGKKI  )  =  QALIIN(L) 

FLAGK2 (I )=QALIRE ( L ) 

ONHAND ( I ) =ONHAND( L ) 

FLAGLf I ) =NQDR( L ) 

FLAGM( I )=SI (L ) 

FLAGN( I ) =PCO( L ) 

FLAGOt I )=CAO( L ) 

FLAGP( I  )=ADMNHR( L ) 

FLAGQ 1 ( I )=PVINP(L) 

FLAG03(  I  )*PEE1.NP(L  ) 

MCTURN 

END 

C  *’*  THIS  SUBROUTINE  CHECKS  FOR  OUT  OF  TOLERANCE  CONDITIONS*'* 
SUBROUTINE  FLGGR ( I , FLAGA , TOPCA , FLAGB , FLAGC 1 . FLAGC2 , FLAGC3 . 

1FLAGC4 , FLAGC5 . FLAGD . FLAGEF . FLAGE , FLAGE 1 . FLAGF . FLAGF 1 . FLAGG  1 . 
2FLAGG2. FLAGH1 , FLAGH2 , TOPDEV , FLAGJ, FLAGK 1 , FLAGK2  ONHAND , FLAGL , 
3FLAGM.  FLAGN,  FLAGO ,  FLAGP  ,  FLAG0 1 .  FLAGQ3  .  FCOUNT  ,  JPtER  .  TOPEPA ) 

INTEGER  FLAGA( 120) , FLAGBI 120).FLAGC1( 120).FLAGC2( t20).FLAGC3( 120) 
1 FLAGC4 ( 120) ,FLAGD( 120) ,FLAGEF( 120)  .FLAGE ( 120) .FLAGF ( 120) . 

2FLAGG2( 120) ,FLAGH1( 120) ,FLAGH2( 1 20 ) . FLAGJ( 1 20) , FLAGK 1 ( 1 20 ) , 
3FLAGK2( 120).FLAGL( 120) . FLAGN( 120) ,  FLAGO( 120),FLAGP( 120) . 

4FLAG0H 120) ,FLAG03( 120) . FLAGC5( 1 20) , FCOUNT( 120) . 

5JPEER( 120 ). FLAGE 1 ( 120) , ONHAND ( 120) 

REAL  A(999,38) .TOPCA ( 120).TOPDEV( 120),FLAGM( 120) .TOPEPAI 120) 

CHARACTER  FLAGG 1( 120)* 1 , FLAGF 1(  120)* 1 .FLAG! 120) *  18 . BFSCM( 2000) *5 

COMMON  /RVAR/A 

COMMON  /CHTR/BFSCM, FLAG 

FLAG( I ) = ' 

FCOUNT ( I )=0 

C  CHECK  FOR  FLAG  CONDITIONS  A  THRU  0 

C  FLAG  C.  ODR  DISTRIBUTIONS  REQUIRE  ANOTHER  SUBROUTINE 

C  FLAG  A  OCCURS  WHEN  THERE  ARE  LOTS  REJECTED  AND  NO  CORRECTIVE  ACTIONS 
C  OF  AT  LEAST  TYPE  B  FOR  TWO  CONSECUTIVE  MONTHS. FOR  FACILITIES 
C  THAT  HAVE  NO  LOTS.  THE  EPA  IS  USED(UNITS  HAVE  BEEN  REJECTED) 

IF  (I  .EQ.  1)  GOTO  14 

IF((FLAGC2(I)  +  FLAGC3(I)*FLAGC4(I)4.FLAGC5(D)  .GT.  0)  GOTO  14 
IF((T0PDEV(I-1)  .GT.  0.0)  .AND.  (  ( FLAGC2 ( I -  1 )  +  FLAGC3( I  -  1 )  + 

1 FLAGC4 (1-1 J+FLAGC5 ( I -  1 )  )  .EQ.  0))  THEN 
FLAG! I )( 1 : 1 )= ' A' 

FCOUNT ( I ) =FCOUNT ( I )+ 1 
GO  TO  14 
ELSE 

I F ( FLAGE (1-1  )  .GT.  O)  GOTO  14 
I F ( TOPEPAt I  -  1  )  .GT.  0.0)  THEN 

IF((FLAGC2(I-1)+FLAGC3(I-1)+FLAGC4(I-1)+FLAGC5(I-1))  .GT.  0) 
1G0T0  14 

FLAG! I ) ( 1 : 1 ) = ' A ' 

FCOUNT ( I )  =  FCOUNT ( I  )  + 1 
ENDIF 
14  ENDIF 

C  FLAG  B  OCCURS  WHEN  MODEL  DETECTS  INTENSIFIED  INSP  HOURS  BUT  NO 
C  CORRECTIVE  ACTION  OF  AT  LEAST  TYPE  B.  MODEL  LOOKS  BACK  ONE 

C  MONTH  TO  SEE  IF  ODR  WRITTEN. 

IF ( ( FLAGB( I )  .GT.  0)  .AND.  ( ( FLAGC2( I )+FLAGC3( I )  +  FLAGC4 ( I  )  + 
1FLAGC5( I  ) )  . EO.  0))  THEN 
I F ( I  .EO.  1)  GOTO  3 

IF ( ( FLAGC21 1-1  )  +  FLAGC3( I-1)+FLAGC4(I-1 )+FLAGC5( I -  1 ) )  .GT.  0) 

1  GOTO  3 

FLAG(I )(2:2)='B/ 

FCOUNT ( I ) =FCOUNT ( I )+ 1 

3  ENDIF 

C  FLAG  C  OCCURS  WHEN  CORRECTIVE  ACTION  DISTRIBUTION  IS  ABNORMAL 

CAl  t  DISTRI  I  .  FLAGC  1  ,  FI  AGC2  .  FL  AGC3 .  F  L  AGC4  .  FLAGC!) .  FCOUNT  ,  JPEFR  ) 

C  FLAG  D  OCCURS  WHEN  MODEL  DETECTS  THREE  MONTHS  OF  NO  MTG  HOURS 
IF (I  . LE .  2)  GOTO  4 

I F ( ( FLAGD( 1-2 )  .EO.  0)  .AND.  (FLAGD(I-I)  ■ EO.  0)  .AND. 

KFLAGDU  )  .EO.  0))  THEN 
FLAGU  )(4:4)='D' 

FCOUNT ( I )  =  F  COUNT ( I ) + 1 

4  ENDIF 

C  FLAG  E  OCCURS  WHEN  MODEL  DETECTS  A  SHIPMENT  WITHOUT  PRODUCT 
C  VERIFICATION  INSPECTION  HOURS. MODEL  LOOKS  BACK  ONE 
C  MONTH  TO  SEE  IF  PVI  OCCURED. 

I F ( ( FLAGEF ( I )  .GT.  0)  .AND.  (FLAGE 1(1)  .EO.  0))  THEN 
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1G040002 
16050002 
16060002 
16070002 
16080002 
16090002 
16100002 
16110002 
16120026 
16130002 
16140002 
16150002 
16160002 
16170002 
16180002 
16190002 
1620000? 
162 10002 
16220002 
16230029 
16240026 
16250099 
16260099 
16270002 
16280002 
16290002 
16300002 
16310099 
16320060 
16330099 
16340099 
16350002 
16360002 
16370002 
16380002 
16390002 
16400002 
16410010 
16420010 
16430010 
16440010 
16450012 
16460099 
16470010 
16480013 
1G490010 
16500010 
16510010 
16520010 
16530010 
16540010 
16550010 
16560013 
16570010 
16580010 
16590010 
16600002 
16610002 
166200C2 
16630010 
16640010 
16650041 
16660010 
16670041 
16680041 
16690002 
16700041 
16710002 
16720060 
16730081 
16740081 
16750081 
16760081 
16770002 
16780002 
16790041 
16800002 
16810002 
16820002 
16830002 


oooooooooooo 


c 

c 


50 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


c 

c 

c 


IF  £  I  .EQ.  1)  GOTO  7 
IF(FLAGEKI-I)  .GT.  0)  GOTO  7 

6  FLAG! 1)(5:5)*'E' 

FCOUNT ( I )  'FCOUNT ( I )+ 1 

7  ENDIF 

FLAG  F  OCCURS  WHEN  MODEL  DETECTS  SHIPMENTS  BUT  NO  VISITS  AT 
A  NONRESIDENT  FACILITY. 

IF( (FLAGEF( I )  .GT.  0)  .AND.  (FLAGFI(I)  .EQ.  'N')  .AND.  (FlAGF(I) 
1  .EQ.  0))  THEN 

FLAG( I )  ( 6 : 6 )  =  '  F  ' 

FCOUNT ( I )=FCOUNT( 1 )+1 
ENDIF 

FLAG  G  OCCURS  UNDER  THE  FOLLOWING  CIRCUMSTANCES 


.  MILO  OR  MILI  FACILITY  AND 

IF  A  RESIDENT  FACILITY,  THERE  IS  NO  PROCEDURE  EVALUATION  DURING 
ANY  MONTH  -  OR 
.  MILQ  OR  MILI  FACILITY  AND 

IF  A  NONRESIDENT  FACILITY.  THERE  IS  EITHER  NO  PROCEDURE 
DURING  ANY  TWO  CONSECUTIVE  MONTHS.  -  OR 
IF  COMMODITY  IS  P7  AND  MILO  OR  MILI  FACILITY  AND 
IF  A  NONPESIOENT  FACILITY.  THERE  IS  EITHER  NO  PROCESS  EVALUATION 
DURING  ANY  THREE  CONSECUTIVE  MONTHS. 

FLAG  IS  SUPPRESSED  FOR  NUCLEAR  FACILITIES 


16840010 
16850002 
1S860002 
16870002 
16880002 
16890002 
16900002 
16910002 
16920002 
16930002 
16940002 
16950002 
16960002 
16970002 
16980063 
16990002 
17000063 
EVALUAT i0N17010063 
17020063 


GO  TO 

•  AND. 

•  AND. 

■  AND. 


50 

(JPEER(I)  .LT 
(JPEER(I)  .LT 
( FLAGG2( I ) 


AND.  ( FLAGG2( I- 1 ) 
(I  .GT.  1))  THEN 


IF(FLAGGHI)  .EQ.  'C') 

IF(  (<JPEER(  I )  .GE.  241) 

I F ( ( JPEER( I )  .GE.  826) 

I F ( ( FLAGF 1(1)  .EG.  'R') 

FLAG( I ) (7 : 7 ) = ' G ' 

FCOUNT ( I )= FCOUNT ( 1  )  + 1 
GO  TO  50 
ENDIF 

I F ( ( FLAGF 1(1)  .EO.  'N') 

1  ( FLAGG2( I )  .EO.  0)  .AND 
FLAGO  )(7:7)«'G' 

FCOUNT ( I )=FCOUNT( I )+1 
GO  TO  50 
ENDIF 

I F ( ( FLAGF 1(1)  .EO.  'N')  .AND.  (FLAGG2(I-1)  . 

1  ( FLAGG2C I )  .EO.  0)  .AND.  (I  .GT.  2)  .AND. 

2  ( FLAGG2 ( I “2 )  .EO.  0)  .AND.  ((JPEER(I)  .EO. 

3  (JPEER(I)  .EO.  284)))  THEN 

FLAG( I ) ( 7 : 7 ) * 'G' 

FCOUNT ( I )* FCOUNT ( I )+ 1 
ENDIF 
CONTINUE 

I F ( ( FLAGF 1(1)  .EO.  'R')  .AND.  (FLAGGI(I)  .NE 
1  (FLAGG2( I )  .EO.  0))  THEN 
FLAG( I ) ( 7 : 7 )■ ' G ' 

FCOUNT ( I )= FCOUNT ( I )+ 1 
ENDIF 

IF ( ( FLAGF 1(1)  .EO.  'N' )  .AND 
1  (FLAGG2(I)  .EO.  0)  . ANO .  (I 
FLAG( I ) ( 7 : 7 ) = ' G ' 

FCOUNT ( I )- FCOUNT ( I )+1 
ENDIF 

1 F ( ( FLAGF 1(1)  .EO.  'N' 1  .AND 


265)) 
850)) 
EO.  0)) 


GO  TO 
GO  TO 
THEN 


50 

50 


EQ.  0)  .AND. 


EO.  0)  .AND. 
283)  .OR. 


'C')  .AND. 


( FLAGG1 ( I )  .NE. 
.EO.  O)  THEN 


( FLAGG  1 ( I )  .NE. 
GT.  1 ) )  THEN 


'C')  .AND. 


'  C ' )  . AND . 


A  CONTRACT  RECEIVED  LAST  MONTH  AND 


1  (FLAGG2U)  .  EO .  0)  .AND.  (I 
I F ( FLAGG2  £  I  -  1 )  .EO.  0)  THEN 
FLAG(I)(7:7)«'G' 

FCOUNT ( I )=FCOUNT( I )+1 
ENDIF 

ENDIF 

FLAG  H  OCCURS  WHEN  MODEL  DETECTS 
NO  PLANNING  HOURS  IN  CURRENT  MONTH  OR  PREVIOUS  MONTH. 

I F ( I  .EO.  1)  GOTO  9 

I F ( ( FLAGH1 ( I  -  1 )  .GT.  0)  .AND.  (FLAGH2(I-1)  .EO.  0))  THEN 
I F ( FLAGH2( I )  .GT.  0)  GOTO  9 

8  FLAG{ I ) ( 8 : 8 ) = 'H' 

FCOUNT ( I ) =rCGUNT ( I )+ 1 

9  ENDIF 

FLAG  I  OCCURS  WHEN  MODEL  DETECTS  LOTS  REJECTED  AND  NO  REINSPECTION 
HOURS  DURING  MONTH  OR  NEXT  MONTH. IF  NO  LOTS  ARE  INSPECTED,  UNIT 
REJECTIONS  WILL  TRIGGER  THE  FLAG. 

I F ( I  .EO.  1)  GOTO  11 

1 F ( ( ( TOPDEVf I -  1  )  .GT.  0.0)  .OR. ( (TOPEPAI I- 1  )  .GT .  0.0)  .AND. 

1 ( FLAGE ( I -  1 1  .EO.  0))J  .AND.  ( FLAGA ( I -  1  )  .EQ.  0))  THEN  ~ 
IF(FLAGA(I)  .GT.  0)  GOTO  11 

10  FLAG(I)(9:9)»'I' 

FCOUNT { I ) =FCOUNT ( I )+ 1 


17030063 
17040063 
17050063 
17060066 
1 7070066 
17080063 
17090066 
17100066 
17110063 
17120002 
17130002 
17140063 
17150002 
17160063 
17170063 
17180002 
17190002 
17200063 
17210002 
17220063 
17230063 
17240063 
17250064 
17260002 
17270002 
17280002 
17290063 
17300063 
17310063 
17320063 
17330063 
17340063 
17350063 
17360063 
17370063 
17380063 
17390063 
17400063 
17410063 
17420063 
17430063 
17440063 
17450063 
17460063 
17470002 
17480002 
17490002 
17500002 
17510002 
17520002 
17530002 
17540002 
17550002 
17560010 
17570010 
17580009 
17590099 
17600010 
17610009 
17620002 
17630002 
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11  ENDIF 

FLAG  d  OCCURS  WHEN  MDR  DAYS  TO  CLOSE  IS  ABOVE  NORMAL 

IF (R£AL( FLAGd( I ) )  .GT.  A(dPEER( I ) , 37 )+2 . 0* ( A( JPEER( I ) , 38 )+ . 001 ) ) 

1  THEN 

FLAG(I)( 10: 10)*'d' 

FCOUNT ( 1 )  =  FCOUNT ( I )+ 1 
ENOIF 

FLAG  K  OCCURS  WHEN  NET  OALI  CHANGE  IS  ABOVE  NORMAL 

NET  OALI  IS  THE  DIFFERENCE  BETWEEN  OALI  RECEIVED  AND  OALI  RESCINDED. 
LIMIT  ON  OALI  CHANGED  TO  +1  SIGMA  BASED  ON  DISCUSSION  WITH  RICH 
ZERILLI  AND  RON  DIPADOVA  CN  29  JUNE  87.  EXCEPTIONS  TO  GUIDANCE  ARE 
GROUPS  26,27,87.127.138.143,148.198,289. 

I F ( REAL( FLAGK1 ( I ) -FLAGK2( I ) ) .GT .  A(dPEER( 1 ) ,31 )  +  1 .0*(A(dPEER{ I  ) , 
IF(REAL(FLAGK1(I ) -FLAGK2( i ) )/( REAL (ONHAND( I ) )+ . 01 )  .GT. 

1  A(JPEER(I),3l)+1.0*(A(dPEER(I).32)+ .001 ) )  THEN 
FLAG(I )( 1 1 : 1 1 ) = ' K ' 

FCOUNT ( 1 ) 'FCOUNT ( I )+ 1 
ENDIF 

FLAG  L  OCCURS  WHEN  THE  NUMBER  OF  NONOAR  ODR  ACTIONS  IS  ABOVE  NORMAL. 
LIMIT  ON  NONOAR  CHANGED  TO  +1  SIGMA  BASED  ON  DISCUSSION  WITH  RICH 
ZERILLI  AND  RON  DIPADOVA  ON  29  JUNE  87.  NO  EXCEPTIONS  TO  GUIDANCE. 
IF(REAL(FLAGL(I))  .GT.  A(dPEER( I ) , 17 )+ 1 . 0» ( A( JPEER( I ) , 18)+.00D) 

1  THEN 

FLAG(I )( 12: 12)*'L' 

FCOUNT ( I )=FCOUNT( I )+ 1 
ENDIF 

FLAG  M  OCCURS  WHEN  THE  SYSTEM  INDICATOR  IS  ABOVE  NORMAL. 

IF(FLAGM(I)  .GT.  30.0)  THEN 

IF(FLAGMd)  .GT.  A(  JPEERd  )  .  33  )t2 . 0*  ( A(  dPEER(I  ) .  34  ) ) )  THEN 
FLAG( I ) ( 13: 13)='M' 

FCOUNT ( I )  =  FCOUNT ( I )+ 1 
ENDIF 

FLAG  N  OCCURS  WHEN  THE  NUMBER  OF  PCO  REQUESTS  IS  ABOVE  NORMAL. 

LIMIT  ON  PCO  CHANGED  TO  +1  SIGMA  BASED  ON  DISCUSSION  WITH  RICH 
ZERILLI  AND  RON  DIPAOOVA  ON  29  JUNE  87.  EXCEPTIONS  TO  GUIDANCE  ARE 
GROUPS  125,197. 

I F ( REAL ( FLAGN( I ) )  . GT .  A ( JPEER(I ) , 9 )+ 1 .0* ( A ( dPEER(I ) . 10)+ . 001 ) ) 

1  THEN 

F  LAG( I ) ( 14: 14 )= 'N' 

FCOUNT ( I ) =FCOUNT ( I )+ 1 
ENDIF 

FLAG  0  OCCURS  WHEN  THE  NUMBER  OF  CAO  REQUESTS  IS  ABOVE  NORMAL. 

LIMIT  ON  CAO  CHANGED  TO  +1  SIGMA  BASED  ON  DISCUSSION  WITH  RICH 
ZERILLI  AND  RON  DIPADOVA  ON  29  JUNE  87.  EXCEPTIONS  TO  GUIDANCE  ARE 
GROUPS  125,197. 

IF(REAL(FLAGO(I ))  .GT.  A ( dPEER (I ) , 1 1 )+ 1 . 0* ( A( dPEERd ) . 1 2 ) + . 00 1 ) ) 

1  THEN 

FLAG(I )( 15: 15)='0' 

FCOUNT ( 1 ) =FCOUNT ( I )  +  1 
ENDIF 

FLAG  P  OCCURS  WHEN  THE  NUMBER  OF  ADMIN  HOURS  IS  ABOVE  NORMAL. 

I F ( REAL ( FLAGPf I ) )  . GT .  A( dPEER (I), 1)+2. 0*(A( dPEER (I),2)+. 001)) 

1  THEN 

FLAG( I  )(  16: 16)  =  'P' 

F''OUNT(I  )  'FCOUNT  (  I  )+1 

Ei'.DIF 

FLAG  0  OCCURS  WHEN  THERE  IS  WORK  NOT  PERFORMED. 
IFf(FLAG0KI)+FLAG03d))  .GT.  0)  THEN 
FLAGd  )(  17:  17)='0' 

FCOUNT (I ) =FCOUNT ( I )+1 
ENDIF 

FLAG  0  OCCURS  WHEN  NO  PE  IS  PERFORMED  AND  WORK  NOT  PERFORMED  IS  NOT 
REPORTED.IT  ALSO  ERASES  THE  G  FLAG  WHrN  WORK  NOT  PERFORMED  IS  SHOWN. 
I F ( FLAG( I ) ( 7 : 7 )  .NE.  'G' )  GOTO  17 
Is( FLAGQ3( I )  .GT.  0)  THEN 
FLAGd  )  (  7  :  7  )  =  '  ' 

FCOUNT ( I )  =  FCOUNT(  I )- 1 
ELSE 

FLAGd  )(  18:  18)='R' 

FCOUNT ( I )= FCOUNT ( I )+ 1 
ENDIF 
17  RETURN 
END 


*»*  THIS  ROUTINE  CHECKS  FOR  UNUSUAL  CORRECTIVE  ACTION  DISTRIBUTIONS. 

SUBROUTINE  DISTR(I , FLAGC 1 , FLAGC2 , FLAGC3 , FLAGC4 , FLAGC5 , 

1 FCOUNT , dPEER) 

INTEGER  FLAGC 1( 120) , FLAGC2( 120) , FLAGC3( 120) ,FLAGC4( 120). 

1 FLAGC5( 120) , FCOUNT { 120) ,dPEER( 120) 


17640002 
17650002 
17660080 
17670002 
17680002 
17690002 
17700002 
17710002 
17720002 
17730002 
17740002 
17750002 
1776C060 
17770027 
17780060 
17790002 
17800002 
17810002 
17820002 
17830002 
17840002 
17850060 
17860002 
17870002 
17880002 
17890002 
17900002 
17910024 
17920070 
17930002 
17940002 
17950002 
17960002 
17970002 
17980002 
17990002 
18000060 
18010002 
18020002 
18030002 
18040002 
18050002 
18060002 
18070002 
18080002 
18090060 
18100002 
18110002 
18120002 
18130002 
18140002 
18150071 
18160002 
18170002 
18180002 
18190002 
18200002 
18210099 
18220002 
18230002 
18240002 
18250072 
18260043 
18270043 
18280099 
18290043 
18300043 
18310043 
18320080 
18330043 
18340043 
18350043 
18360011 
18370002 
» 18380002 
18390002 
18400054 
18410060 
18420002 
18430060 
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CHARACTER  FI_AG(  120)  *  18  ,  BFSCM!  2000)  *5  18440099 

REAL  A( 999 , 38 )  18450054 

COMMON  /RVAR/A  18460002 

COMMON  /CHTR/BFSCM. FLAG  18470002 

I ACNT  =0  18480002 

IBCNT  =0  18490002 

ICCNT  =0  18500002 

IDCNT =0  18510002 

I ECNT  =0  18520002 

DO  1  K=  1 , 1  18530002 

I ACNT  =IACNT+FLAGC1 (K)  18540004 

IBCNT  = IBCNT+FLAGC2(K)  18550004 

ICCNT=ICCNT+FLAGC3(K)  18560004 

IDCNT  =  IDCNT+FLAGC4(K )  18570004 

I ECNT  = IECNT*FLAGC5(K)  18580004 

CHECK  FOR  UNDER  ESCALATION  OF  CORRECTIVE  ACTION  18590002 

SINCE  TYPICALLY  THE  STO  DEV  OF  ODR  DATA  EXCEEDS  THE  MEAN.  THE  18600002 

DETECTION  OF  UNDER  ESCALATION  IS  TRIGGERED  BY  BEING  EELOW  AVG.  18610002 

I  F ( ( RCAL  < I ACNT )/REAL(K)  . GT .  A( JPEER( I ) . 19 )+ 1 .0* A( JPEER(I ) . 20) )  18620060 

1  . AND .  ( REAL ( IBCNT )/REAL (K )  .LT.  A( JPE ER( I  ) .  2 1 )  )  )  GOTO  2  18630060 

I F( (REAL! IBCNT )/REAL ( K )  .GT.  A ( JPEER( I ) . 2 1 )+ 1 . 0*A < JPEER ( I ) , 22  ) )  13640060 

1  AND  ( ( REAL ( ICCNT I/REAL ( K )  .LT.  A( JPEER ( I  ) . 23 ) )  AND.  18650060 

2(  REAl  (  I  FONT  )/Rf  Al  ( K  )  IT.  A  (  JPEFR  ( I) .  27  )  )  )  )  GOTO  2  18660060 

II  (((RLAKICCNI  )/R[AL(K)  GI  A! JPEER! 1  ) ,  23  M3  0* A( JPEER! 1  ) ,  24  18670060 

!))  .OR  (REAL! lECNf )/REAL(K)  .GT.  A! JPEER! I ) . 27 )  +  3 .0* A ( JPEER!  I) .  18680060 

228)))  .AND.  (REAL( IDCNT )/REAL(K)  . LT .  A( JPEER ( I ) . 25  ) )  )  GOTO  2  18690060 

GO  TO  1  18700002 

2  Fl AG(K)(3:3)='C'  18710002 

(K  .EO.  I)  F COUNT ( I )= FCOUNT ( I )+ 1  18720002 

1  C  -  INUE  18730002 

100  RETURN  18740002 

END  18750002 

18760002 

”*  THIS  SUBROUTINE  COMPUTES  THE  PROCESS  EFFECTIVENESS  BY  DEDUCTING  18770002 
POINTS  FOR  EACH  RED  FLAG  GENERATED.  ALSO  THE  PROCESS  SCORE  IS  18780002 

COMBINEO  WITH  THE  PRODUCT  SCORE  TO  COMPUTE  AN  OVERALL  SCORE.  18790002 

PRIOR  MONTH  SCORES  ARE  NOTED.  18800099 

SUBROUTINE  SCORER ( 1 . FCOUNT , TOPSCR , TP , JSTRAT )  18810002 

INTEGER  FCOUNT ( 1 20) . JSTRAT ( 1 20)  18820002 

CHARACTER  TP( 120)T1  18830002 

REAL  T0PSCR(14. 120)  18840099 

TOPSCR ( 10, I )  = 100.0  18850002 

TOPSCR! 12, I )=0.0  18860099 

TOPSCR ( 13. I ) =0.0  18870099 

T0PSCR( 14.1 )=0.0  18880099 

IF(TPU)  .EO.  'R')  THEN  18890002 

I F ( JSTRAT ( I  )/5*5  .EO.  JSTRAT(I))  THEN  18900002 

VERY  LARGE  RESIDENT  PENALTY  IS  15  PTS  PER  FLAG  EXCEPT  FIRST  -10  PTS  18910074 
I F ( F COUNT ( I )  .LE.  1)  THEN  18920074 

TOPSCR! 10. I )= 100.0- 10.0* FCOUNT ( I )  18930074 

GO  TO  10  18940074 

ELSE  18950074 

TOPSCR! 10. I )= 105 .0- 15 .0* FCOUNT ( I )  18960074 

ENDIF  18970076 

ELSE  18980076 

MOST  RESIDENT  PENALTY  IS  15  POINTS  PER  FLAG  18990074 

TOPSCR! 10,1 )= 100.0- 15 .0* FCOUNT ( I )  19000076 

ENDIF  19010076 

ELSE  19020076 

NONRESIDENT  PENALTY  IS  20  POINTS  PER  FLAG.  19030074 

TOPSCR! 10. I )= 100.0-20 .0* FCOUNT ( I )  19040074 

>  ENDIF  19050002 

I F ( TOPSCR! 10,1)  .LT.  0.0)  TOPSCR ( 10. I ) =0 . 0  19060075 

TOPWT  = . 4  19070002 

CQAPWT  = . 6  19080002 

TOPSCR! 1 1 , I )= TOPSCR! 8 , I ) *TOPWT+TOPSCR( 10. I )*COAPWT  19090032 

I F ( I  .EO  1)  THEN  19100002 

GO  TO  20  19110099 

ELSE  191200S3 

TOPSCR! 12,1 )=T0PSCR(8.I-1)  19130099 

I F ( I  .EO.  2)  THEN  19140099 

GO  TO  20  19150099 

ELSE  19160099 

TOPSCR! 13,1 )= TOPSCR (8 . 1 -2 )  19170099 

I F  ( I  .EO.  3)  THEN  19180099 

GO  TO  20  19190099 

ELSE  19200099 

TOPSCR! 14,1 )  =  TOPSCR! 8 . 1 -3  )  19210099 

ENDIF  19220099 

ENDIF  19230099 
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ENDIF 

RETURN 

END 


192^0099 

19250099 

19260002 


C  THIS  MODULE  ADDS  THE  NAME  AND  CAO  CODE  TO  THE  REPORT  INPUT  RECORD. 

C  THIS  IS  DONE  BY  MATCHING  THE  CAGE  CODE  WITH  THE  ADRS  FILE.  THE  ADRS 
C  FILE  MUST  BE  FLATTENED  WITH  IEBGENER  IN  THE  PRODUCTION  VERSION 
C  OF  QUEST  III . 

C 

CHARACTER  FSCM 1 *5 . FSCM2 * 5 , BEFORM . AFTER* 147 , CAO»? . NAMF*20 
(  IN1 1  I  AI.I  70  VARIABLE 
rSCM?*' 

C  READ  A  RECORD  FROM  REPORT  INPUT  FILE 

10  READ  (1, 11,END=100)  BEFOR , FSCM1 . AFTER 

11  FORMAT { A4 , A5 , A  147  ) 

C  COMPARE  FSCM'S 

15  IF( FSCM1  .EQ.  FSCM2)  GO  TO  40 
I F ( FSCM 1  .LT.  FSCM2  )  THEN 
C  I F ( LGT ( FSCM1 . FSCM2 ) )  THEN 

GO  TO  30 
ELSE 

GO  TO  20 
END  IF 

C  READ  A  RECORD  FROM  THE  ADRS  FILE 

20  READ ( 2 ,21, END =10)  FSCM2 . CAO . NAME 

21  FORMAT ( 1X.A5.A2.3X.A20, 15X) 

GO  TO  15 

C  ADRS  FILE  IS  AHEAD  OF  RECORD  INPUT  FILE 
C  READ  ANOTHER  INPUT  RECORD  AND  DEFAULT 

30  WRITE ( 3 , 3 1 )  BEFOR . FSCM1 . AFTER 

31  FOR  MAT ( A4 , A5 , A 1 47 ,  '  ') 

GO  TO  10 

C  A  MATCH  HAS  BEEN  FOUND.  APPEND  DATA  TO  INPUT  FOR  OUTPUT 

40  WRITE(3,41)  BEFOR. FSCM1, AFTER, CAO. NAME 

41  FORMAT (A4,A5,A147,A2,A20) 

GO  TO  10 

100  STOP 
END 


00010000 
00020000 
00030000 
00040012 
00050000 
00060018 
00070001 
00080001 
00090001 
00100001 
001 10018 
00120001 
00130004 
00140008 
00150007 
00160007 
00170004 
00180007 
00190001 
00200001 
00210001 
00220001 
00230001 
00240001 
00250001 
00260001 
00270018 
00280001 
00290001 
00300001 
00310018 
00320001 
00330001 
00340001 
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//G0R6O4OE  JOB  ( 6040. GOR) . 'GROVER' ,CLASS=O.MSGCLASS=V 
//RUNFTN  EXEC  FORTVCG 

//FORT . SYSIN  DO  DSN=GOR . GROVER . QUEST3( REPORT  1 ) , DISP=SHR 
//GO . FT 12F001  OD  DSN=GOR .GROVER . LA . REPZM.DI SP=SHR 
//G0.FT13F001  DO  DSN=GOR . GROVER . SCORES . MAY90A , DISP=SHR 
/ / GO . FT  1 4F00 1  DO  DSN=GOR. GROVER. DMINS . LAZM . 0CT89 . 

/,  DI SP= ( NEW. CAT LG, DELETE ) , UNIT=WORKD , 

S^ACE  =  ( TRK . ( 9 , 9 ) . RLSE ) , OCB  =  ( RECFM=FB,LRECL=152 , BLKSI ZE  =  1 5200) 
. /'0.FT16F001  DD  OSN=GOR. GROVER. QUEST. OUTPUT. 

//•  01 SP= ( MEW. CATLG, DELETE ) , UNI T=TAPE , 

// •  DCB  =  ( R£CFM=FB,LRECL=133 . BLKSI 2E=  13300)  . 

//•  l_ABEL  =  EXPDT=91 181 
//GO  FT06F001  DD  SYSOUT=* 

//SYSOUT  OD  SYSOUT  =  * 

//3YSUDUMP  OD  SYSOUT=* 

//SYSPRINT  DD  SYSOUT=* 

// 


00010099 
00030012 
00040099 
00050099 
00060099 
00070099 
00071099 
00072099 
00080099 
00080199 
00080299 
00080399 
00081099 
00090000 
00100000 
001 10000 
00120000 
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THIS  IS  THE  QUEST  III  VERSION  Of  REPORT  GENERATOR  TAKEN  PROM  00010099 
QUEST  II  VERSION  GOR. GROVER. F0R(DMINRPT4).  00011099 
THIS  VERSION  IS  USED  TO  PRODUCE  A  SIMULATED  REPORT  BASED  ON  5A  QARCQDE00012099 


THIS  IS  THE  PRODUCTION  VERSION  TO  BE  PASSED  TO  DSAC  AND  FIELDED  00013099 

THE  CONCEPT  BEHIND  THIS  VERSION  IS  TO  PASS  ALL  QUEST  II  PARAMETERS  00020099 
BUI  TO  SUPPRESS  PRINTING  FLAGS,  PROGRAM  SCORES.  ETC.  00030099 

REPORT  IS  LIMITED  TO  PRODUCT  SCORES.  00040099 

*»  THIS  PROGRAM  GENERATES  A  DMINS  FILE  00060099 

OECLARE  AND  ARRAY  VARIABLES  00070099 

CHARACTER  ORGCD( 500) *3 . 0RG*3 , FSCM( 500) *6 , FLAG( 500)* 18 . TYP( 500) *  1  00080099 

CHARACTER  QAR ( 500 ) * 5 , CAO ( 500 ) *2 . NAME ( 500 ) * 20 , CMDTY ( 500 ) * 2  00090099 

CHARACTER  PVN(500)*1  00091039 

INTEGER  MONTH ( 500) . YEAR ( 500) . DEGREE ( 500) . YR . GRP ( 500)  00100099 

INTEGER  1 SI2R( 500) , STARTM, ST ARTY . ENDMO, ENDYR ,NOAR( 500)  00110099 

REAL  EFF( 13 , 500) . REGCUM( 1 1 ) ,SECCUM( 11,3), BRACUM( 1 1 ) ,DIVCUM( 1 1 )  00120099 

REAL  A (999, 2)  00130099 

INITIALIZE  COUNTERS  AND  CUMULATORS  00140099 

CALL  INIT( REGCUM, SECCUM , BRACUM, DI VCUM, BRAN, SECT , DI VN)  00150099 

READ  IN  PEER  SCORES  00160099 

1=0  00170099 

11=0  00180099 

2  1=1+1  00190099 

SCI  DEFAULT  VALUES  00191099 

I F ( I  .LT  500)  THEN  00192099 

A(  1.1  )  =93. 53  00200099 

A( I , 2  )  =  10.85  00210099 

ELSE  00211099 

A(I,  0  =  77.97  00212099 

A(I,2)=14.79  00213099 

END IF  00214099 

I F  ( 1 1  .  GT .  I)  GOTO  2  00220099 

R£AD( 13 , 14 )  II , A( I , 1  ) , A ( I ,2)  00230099 

14  FORMAT ( 17X,I3,2SX.F8.4,3X,F8.4,68X)  00240099 

I  Fill  .GT.  1)  THEN  00250099 

A<  II  .  1  )  =  A( 1.1)  00260099 

A(II.2)=A(I,2)  00270099 

DO  4  K= 1 , 1 1 -  1  00280099 

I F (K  .LT.  500)  THEN  00281099 

A (K. 1)*93.S3  002820S9 

A ( K , 2 ) *  10. 85  00283099 

ELSE  00284099 

A(K, 0=77.97  00285099 

A(K.2)=14.79  00286099 

END IF  00287099 

4  CONTINUE  00310099 

I  =  1 1  00320099 

END IF  00330099 

IF( 1 1  .LT.  999)  GOTO  2  00340099 

00  3  J= 1,999  00350099 

WRITE(6, 14)  J. A(U, 1 ) . A(U,2)  00360099 

3  CONTINUE  C0370099 

READ  FIRST  RECORD  00380099 

READ! 12. 15 , END=99 )  ORGCD( 1 ) . FSCM( 1 ) . TYP( 1) .CMDTY ( 1 ) ,PVN( 1 ) ,NQAR( 1 )00390099 


1 , MONTH! 1 ).YEAR( 1). ISIZR( 1).GRP( 1 ), DEGREE ( 1),0AR( 1) ,FLAG( 1),  00400099 

2EFF (  1  .  1) ,EFF(2, 1).EFF(3.  1),EFF(4, 1),EFF(5, 1),EFF(6,  1).EFF(7, 1).  004  10099 

3EFF ( 8 .  1  ) , EFF ( 9 . 1 ),EFF( 10, 1 ),EFF( 11, 1 ) , EFF ( 12. 1 ) ,EFF(  13, 1),  00420099 

4STARTM.STARTY, ENDMO , ENDYR , CAO ( 1 ) , NAME ( 1 )  00421099 

15  FORMAT (A3. A6.A1 .A2.A1 ,313,214, 12, A5, A  18, 13F7 . 1 , 4 12 , 2X , A2 , A20)  00422099 

DO  13  U= 1 , 1 1  00430099 

IF(TYP(1)  .EQ.  'R')  THEN  00440099 

IF(ISIZR(1)  .EO.  385)  ISIZR(1)=391  00450099 

IRESCT=(MOD( (ISIZR(1 )+4) ,5)+1 )’*2  00460099 

S£CCUM(U, 1 )=EFF(U, 1 ) *REAL( IRESCT )  00470099 

NRESCT=0  00480099 

ELSE  00490099 

SECCUM(U, 2 )=EFF ( U ,  1)  00500099 

NRESCT  = 1  00510099 

IRESCT=C  00520099 

END IF  00530099 

13  CONTINUE  00540099 

READ  REMAINING  RECORDS  FOR  SECTION  00550099 

11  L IN=0  00560099 

00  20  1=2,500  00570099 

READ( 12 , 16 , END =99 )  ORGCD( I ) . FSCM( I ) , TYP( I ) , CMDTY ( I ) , PVN( I ) , NQAR( I )0061 1099 
1 ,MONTH( I ) . YEAR( I ) , ISIZR( I ) ,GRP( 1 ) .DEGREE ( I ) ,OAR( I ) . FLAG( I ) ,  00612099 

2EFF (1,1), EFF (2. I), EFF (3. I), EFF (4, I), EFF (5, I), EFF (6, I), EFF (7, I),  00613099 

3EFF(8,I),EFF(9,I),EFF(10,I),EFF(11,I),EFF( 12,1), EFF (13,1),  00614099 

4CA0 ( I ) , NAME ( I )  00615099 

16  FORMAT (A3 ,A6,A1 ,A2,A1 .313,214, I2,A5,A18, 13F7.1. 10X.A2.A20)  00620099 


C  '*»  IF  A  NEW  MONTH  IS  FOUND,  UPDATE  ALL  SUMMARY  STATS. 

IF(MONTH(I)  .NE,  MONTH(I-I))  THEN 
101  CALL  HEADR(I .MONTH, YEAR. ORGCD.CAO) 

CALL  WR ITER( I .LIN, FSCM, GRP, DEGREE, FLAG, EFF, MONTH, YEAR, ORGCO . A. 

1 T YP , OAR , CAO , NAME , CMDTY , PVN , STARTM . START Y , NOAR ) 

CALL  SECTOT( I , SECCUM. IRESCT , NRESCT. EFF. ORGCD, FSCM, YEAR. MONTH, 

1 GRP , DEGREE , FLAG , BRACUM , TYP , SECT ,ORG, MON, YR , CAO .NAME , 

2 1 S I ZR , OAR , CMDTY , P VN , NOAR ) 

CALL  BRATOT( BRACUM, BRAN, SECT. 01 VCUM.ORG, MON, YR) 

CALL  DIVTOT(DIVCUM,DI VN.BRAN.REGCUM.ORG, MON, YR) 

CALL  REGTOT ( REGCUM, DI VN. MON, YR ) 

I F( I ENDR  .EO.  1)  GOTO  100 
GO  TO  11 
END1F 

C  IF  A  NEW  DIVISION  IS  FOUND,  UPDATE  ALL  SUMMARY  STATS. 

I F ( ORGCD* I ) ( 1 ■ 1 )  .NE.  ORGCD( I  - 1 ) ( 1 : 1 ) )  THEN 
CALL  HEADR* I . MONTH. YE AR , ORGCD . CAO ) 

CALL  WRITER* I .LIN, FSCM. GRP. DEGREE, FLAG. EFF .MONTH, YEAR, ORGCD, A, 

1  TYP . OAR , CAO . NAME , CMDTY , PVN , STARTM . START Y , NOAR ) 

CALL  SECTOT (I .SECCUM, IRESCT, NRESCT, EFF. ORGCD, FSCM. YEAR, MONTH, 
1GRP, DEGREE .FLAG, BRACUM, TYP, SECT.ORG. MON, YR, CAO, NAME. 

21  SI ZR , OAR , CMDTY , PVN , NOAR ) 

CALL  BRATOT (BRACUM , BRAN .SECT , DI VCUM . ORG , MON , YR ) 

CALL  DI VTOT(DI VCUM, 01 VN, BRAN, REGCUM, ORG, MON. YR) 

GO  TO  11 
ENDIF 

C  ***  IT  A  NEW  BRANCH  IS  FOUND.  UPDATE  ALL  SUMMARY  STATS. 

I F ( ORGCD ( I ) ( 1 : 2)  .NE.  ORGCD* I - 1 ) ( 1 : 2 ) )  THEN 
CALL  HEADR* I . MONTH. YE AR . ORGCD . CAO ) 

CALL  WRITER* I . L IN . FSCM, GRP , DEGRE E , FLAG , EFF , MONTH , YEAR . ORGCD , A . 
IT YP . OAR . CAO . NAME , CMDTY , PVN , STARTM , STARTY , NOAR ) 

CALL  SECTOT ( I , SECCUM .IRESCT , NRESCT , EFF , ORGCD , FSCM, YEAR . MONTH. 
1GRP. DEGREE .FLAG. BRACUM. TYP, SECT. ORG, MON. YR, CAO. NAME. 

2 1 S I ZR . OAR . CMDTY . PVN , NOAR ) 

CALL  BRATOT ( BRACUM , BRAN . SECT . 0 I VCUM . ORG . MON . YR ) 

GO  TO  11 
ENDIF 

C  «*•  IF  A  NEW  SECTION  IS  FOUND.  UPDATE  ALL  SUMMARY  STATS. 

IF*  ORGCD* I  )  ( 1 : 3 )  .NE.  ORGCD* I -  1 ) ( 1 : 3 ) )  THEN 
CALL  HEADR* I . MONTH. YE AR . ORGCD , CAO) 

CALL  WRI TER* I .LIN, FSCM, GRP. DEGREE, FLAG. EFF. MONTH. YEAR. ORGCD. A. 
1TYP , OAR . CAO , NAME . CMDTY , PVN , STARTM . STARTY . NOAR ) 

CALL  SECTOT* I .SECCUM, IRESCT, NRESCT, EFF, ORGCD. FSCM. YEAR, MONTH. 

1 GRP . DEGRE  E . FLAG , BRACUM , TYP , SECT . ORG , MON , YR . CAO , NAME , 

2 1 S I ZR . OAR . CMDTY , PVN , NOAR ) 

GO  TO  11 

C  CURRENT  RECORD  IS  IN  THE  SAME  SECTION.  UPDATE  SECTION  COUNTERS 
ELSE 

IF* TYP ( I )  .EO.  'R' )  THEN 
IF* ISIZR* I  )  .EO.  G25 )  ISIZR(I)=991 
I RE SCT= IRESCT* (MOD* ( ISIZR* I )+4 ) ,5)+1 )**2 
DO  23  0=1,11 

SECCUM* 0. 1 )=SECCUM(0. 1 )+EFF ( J , I ) * (REAL (MOD* ( ISIZR* I )+4) ,5)+1 ) ) 
1  "2 

23  CONTINUE 
ELSE 

NRESCT=NRESCT+ 1 
DO  24  0=1.11 

SECCUM*  0. 2 )  =  SECCUM* 0, 2  )  +  EFF  ( J  , I ) 

24  CONTINUE 
ENDIF 

ENDIF 

20  CONTINUE 

98  WRITE (6 , 97 ) 

97  FORMAT* IX, 'TOO  MANY  FACILITIES  ASSIGNEO  TO  SECT  ION . ABNORMAL  END') 
C  NORMAL  END  .  FINISH  PROCESSING  LAST  ORGS  AND  END  OOB . 

99  I ENDR= 1 
GO  TO  101 

100  STOP 
END 

SUBROUTINE  INI T( REGCUM , SECCUM , BRACUM, DI VCUM, BRAN, SECT , DIVN) 

REAL  SECCUM* 1 1 ,3) .BRACUM* 1 1 ) .REGCUM* 1 1 ) .DIVCUM* 11 ) 

DO  10  1=1.11 
REGCUM* I ) =0. 0 
SECCUM(I. 1)=0.0 
SECCUM* I . 2 )=0 .0 
SECCUM* I , 3 )=0 .0 
BRACUM* I ) =0.0 
DIVCUM* I )=0.0 
10  CONTINUE 


00622099 
00640099 
00650099 
00660099 
00670099 
00680099 
00690099 
00700099 
00710099 
00720099 
00730099 
00740099 
00750099 
00760099 
00770099 
00780099 
00790099 
00800099 
00810099 
00820099 
00830099 
00840099 
00850099 
00860099 
00870099 
00880099 
00890099 
00900099 
00910099 
00920099 
00930099 
00940099 
00950099 
00960099 
00970099 
00980099 
00990099 
01000099 
01010099 
01020099 
01030099 
01040099 
01050099 
01060099 
01070099 
01080099 
01090099 
01100099 
01120099 
01 130099 
01 140099 
01150099 
01160099 
01 170099 
01180099 
01 190099 
01200099 
01210099 
01220099 
01230099 
01240099 
01250099 
01260099 
01270099 
01280099 
01290099 
0 1 300099 
01310099 
01320099 
01330099 
01340099 
01350099 
01360099 
01370099 
01380099 
01390099 
01400099 
01410099 
01420099 
01430099 
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BRAN=0.0 
SECT =0.0 
DIVN=0.0 
RETURN 
END 

SUBROUTINE  HEADR! I , MONTH. YEAR . ORGCD. CAO ) 

INTEGER  MONTH! 500 1 , YE AR( 500 ) 

Cl  1AR AT- 1  r R  ORGCD (  BOO )  *  3  .  C AO (  500 )  ♦  2 
Nl/I  I  INI  Mll‘Pk'1 ',sr:,  ALL  BUI  1  1NAI  MONIII  1ILADER 
WIIIUIC .  17)  MONTH  (  I  -  1  )  .  YEARL  I  -  1  ), ORGCD!  1  -  1  )  .  CAOL  I  -  I ) 
FORMAT! ' 1 • .213. '  QUEST  REPORT  FOR  SECTION  '.A3.5X.A2/ 


01440099 

01450099 

01460099 

01470099 

01480099 

01490099 

01500099 

01510019 

01510199 

01520099 

01571099 


1  BOX. 'CONTRACTOR  EFFECTI VENESS ' . 27X . ' F IRST ' . '  SECOND'.'  THIRD'/  01571199 

1  '  ' ,2X, 'CAGE', 5X, 'NAME  OAR  COMM/  QAS' . 2X , 'CA '. 5X ,' POOR ' .  01572099 

2  5X, 'PA' ,5X. 'WVRS ' . 5X . ' MRB ' ,5X, 'DEVN' ,5X. 'ECP' ,5X, 'TOTAL' , 3X ,  01573099 

3  'PRIOR  PRIOR  PRIOR' ,5X, 'PEER'/'  '.26X.'PVN  '. 62X .' SCORE ' ,  01574099 

4  3X, 'MONTH' ,3X, 'MONTH' ,3X, 'MONTH' ,4X, 'GRP/RTG' )  01575099 

10  RETURN  01580099 

END  0159C099 

SUBROUTINE  WRITER! I .LIN. FSCM. GRP. DEGREE. FLAG. EFF, MONTH. YEAR, ORGCD. 01600099 


1 A . TYPE . OARCD . CAO . NAME . CMDTY . PVN . STARTM. STARTY , NOAR ) 

INTEGER  DEGR£E(500) ,MONTH(500) ,YEAR(500) ,GRP(500) .STARTM, STARTY 
INTEGER  NOAR! 500) 

CHARACTER  FLAG(500)’ 18 . FSCM( 500) »6 . ORGCD! 500) *3 . RANKI T* 1 
CHARACTER  TYPE ( 500) *  1 , OARCD ( 500) *  5 , CAO ( 500) *  2 , NAME ( 500) *20 
CHARACTER  CMDTY ( 500 ) *2 . PVN( 500 ) *  1 
REAL  EFF(  13.500) ,A(999, 2) 

LIN=0 
NUML1N=I 
KPG=0 

10  DO  18  KK= 1 . 60 

10  00  18  KK=1 .50 

K=KPG*50+KK 
LIN=LIN+1 

1 F ( L IN  . GE .  NUMLIN)  GOTO  22 
I F ( K  GT,  1)  THEN 

IF! (DEGREE !K- 1 )  ,LT.  3)  .AND.  (DEGREE(K)  . GE .  3))  THEN 
WR I TE ( 6 , 15) 

15  FORMAT!'  ') 

ENDIF 
ENDIF 

CALL  PEER! K , GRP . EFF , A . RANK IT ) 

IF(DEGREE(K)/2*2  .NE.  DEGREE(K))  FSCM(K) ( 1 : 1 )= ' * ' 

I F ( ( MONTH! K )  .EQ.  STARTM)  .AND.  ( YEAR(K)  .EQ.  STARTY))  THEN 
WRITE (6. 23)  FSCM! K). NAME (K) ( 1 : 10) , OARCD! K ). CMDTY ( K ). PVN( K ) . 

2N0AR! K ).EFF(7,K),EFF(8,K),EFF(2,K),EFF(5.K),EFF(4,K),EFF(3,K), 
3EFF(6.K),EFF(9.K), GRP ( K ) , RANKI T 

23  FORMAT! IX , A6 , 1 X . A  10 , IX . A5 . IX , A2 , IX , A  1 . IX , 1 3 . 2X , 7 ( F5 .  1 , 3X  )  . 2X , 

1  F5. 1 .27X. I4.2X.A1 ) 

GO  TO  25 
ENDIF 

I F ( ( ( MONTH! K )  .EQ.  STARTM+ 1 )  .AND.  (YEAR(K)  .EQ.  STARTY))  .OR. 

1  ( ( MONTH! K )  . EQ.STARTM-1 1 )  .AND.  (YEAR(K)  . EO . STARTY* 1  )) )  THEN 
WRITE (6, 21 )  FSCM(K) ,NAME(K)( 1:10) , OARCD! K) , CMDTY (K ) , PVN(K ) . 

2NQAR(K ).EFF(7.K),EFF(8,K),EFF(2.K),EFF(5,K),EFF(4.K),EFF(3,K) . 
3EFF(6,K),EFF(9,K) ,EFF( 1 1 . K ) . GRP( K ) , RANKIT 
21  FORMAT! IX, A6, 1X.A10, 1X.A5. 1X.A2, 1X.A1 . 1X,I3,2X,7(F5. 1 ,3X),2X, 

1  F5  1 .3X.F5. 1 ,  19X, I4.2X, A1 ) 

GO  TO*  25 
ENDIF 

IF! ( (MONTH! K)  .EO.  STARTM+2)  .AND  ( YEAR! K )  .EQ.  STARTY))  .OR. 

1  ( ( MONTH! K )  .EO  STARTM- 10)  .AND.  (YEAR(K)  . EQ . ST ARTY* 1 )  ) )  THEN 
WRITE (6, 20)  FSCM(K) ,NAME(K)( 1 . 10) . OARCD! K ), CMDTY (K ), PVN(K ) . 

2NQAR (K),EFF(7,K),EFF(8,K),EFF(2,K),EFF(5,K),EFF(4,K),EFF(3,K), 
3EFF(6,K),EFF(9,K),EFF(11.K),EFF( 1 2 ,K ) ,GRP( K ). RANKIT 
20  FORMAT! IX . A6 . IX , A  10 . IX , A5 . 1 X , A2 . IX , A  1 , IX , I  3 . 2X . 7 ( F5 . 1 , 3X ) , 2/ , 

1  F5. 1 .3X.F5. 1 .3X.F5. 1 , 11X, I4.2X.A1) 

GO  TO  25 
ENUlF 

WRITE (6. 24)  FSCM! K ) , NAME(K) ( 1 : 10) , QARCD(K ) . CMDTY ( K ) . PVN( K ) , 

INQAR(K) ,EFF(7,K),EFF(8,K),EFF(2,K), 
2EFF(5,K),EFF(4,K),EFF(3,K),EFF(6,K),EFF(9,K),EFF(11,K),EFF( 12.K).  02042199 
3EFF ( 13 ,K ) , GRP! K) , RANKiT  02043099 

24  FORMAT! IX . AS . IX . A 10 . IX . A5 , IX , A2 . IX , A  1 . IX . 1 3 . 2X . 7( F5 . 1 , 3X ) , 2X ,  02044099 

14(F5.1.3X).I4.2X.A1)  02045099 

25  WRITE! 14,27)  ORGCD(K) . FSCM(K) ( 2 : 6 ) . FLAG(K) , EFF ( 1 , K) , EFF ( 2 . K ) ,  02050099 

1EFF(3,K).EFF(4,K),EFF(5,K),EFF(6,K),EFF(7,K),EFF(8,K),EFF(9,K),  02060099 

2EFF ( 10, K). EFF! 1 1 . K ), RANKIT , FSCM( K) ( 1 : 1 ). YEAR(K) ,MONTH(K ). TYPE ( K ) ,  02070099 
3QARCD (K) , NAME ( K ) , GRP ( K ) , CAO ( K ) , NQAR (K) , CMDTY (K) , PVN(K)  02080099 

27  FORMAT (A3, ' 1 ' , A5 , ' t ' , A 18 . ' 1 ' . 3( F5 . 1 , ' t ' ) , 8(F5 . 1 , ' T ' ) .  02090099 

12(A1.'1').2(I2,'1').'5'.'t'.A1.'t'.A5,'t' ,A20, ' t ' . 1 4 . ' T ' , A2 , ' T ' .1302100099 
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01610099 

01620099 

01630099 

01640099 

01650099 

01651099 

01660099 

01670099 

01680099 

01690099 

01700099 

01710099 

01720099 

01730099 

01740099 

01741099 

01742099 

01743099 

01744099 

01745099 

01746099 

01800099 

0'800199 

01801099 

01801199 

01801399 

01801499 

01801599 

01801699 

01802099 

01803099 

01804099 

01804199 

01805099 

01806099 

01807099 

01808099 

01809099 

01810099 

01820099 

01830099 

01840099 

01850099 

01860099 

01870099 

01880099 

01890099 

01900099 

01910099 

02041099 

02042099 


2,'T',A2,'t',A1) 

18  CONTINUE 

CALL  HEADR(I .MONTH. YEAR, ORGCD.CAO) 

KPG=KPG+ 1 
GO  TO  10 
22  RETURN 
END 

SUBROUTINE  PEER! K . GRP , EFF . A , RANK! T ) 

INTEGER  GRP(SOO) 

CHARACTER  RANKIT* 1 
REAL  EFF( 13.500) ,A(999. 2) 

IF  UEFFO.K)  .GT.  A(GRP(K) ,  1  )+A(GRP(K)  ,2)  )  .OR.  ( EFF  (9 ,  K)  .GE. 
1  100.0))  THEN 

RANKIT  =  '  A ' 

GO  TO  10 
END  IF 

IF ( GRP(K )  .GT.  500)  THEN 

IF  ( EFF ( 9 , K )  .GT.  A( GRP(K ) , 1 )+ . 5* A(GRP(K) ,2 )  )  THEN 
RANKIT  « 'B ' 

GO  TO  10 
ENDIF 

IF  ( £ FF ( 9 , K )  .GT.  A (GRP ( K ) . 1 ) - . 5* A ( GRP( K ) , 2 ) )  THEN 
RANKIT ■= '  C ' 

GO  TO  10 
ENDIF 

IF  ( EFF ( 9 , K )  .GT.  A ( GRP ( K ) . 1 ) -A ( GRP( K ) , 2  ) )  THEN 
RANKIT  = ' D ' 

GO  TO  10 
ENDIF 

RANKIT ■ ‘ F ' 

GO  TO  1C 
ELSE 

IF  ( EFF ( 9 , K  )  .GT.  A(GRP(K).1))  THEN 
RANKIT  * 'B' 

GO  TO  10 
ENDIF 

IF  ( EFF ( 9 , K )  .GT.  A ( GRP ( K ) . 1 ) -  1 . 0* A (GRP ( K ) . 2 ) )  THEN 
RANKIT11 '  C ' 

GO  TO  10 
ENDIF 

IF  ( EFF (9 , K)  .GT.  A(GRP(K) . 1 )-2.0*A(6RP(K),2))  THEN 
RANKIT  =  '  D ' 

GO  TO  10 
ENDIF 

RANKIT  = ' F ' 

GO  TO  10 
ENDIF 
10  RETURN 
END 

SUBROUTINE  SECTOT ( I , SECCUM, IRESCT , NRESCT , EFF . ORGCD , FSCM. YEAR . 

1 MONTH . GRP , DEGRE  E , F  L AG . BRACUM , T YP . SECT , ORG . MON , YR . CAO , NAME . 

2 1 S I ZR . OAR , CMDTY . PVN , NOAR  ) 

CHARACTER  ORGCD! 500) *3 , FSCM( 500 ) *6 , FLAG! 500 ) » 1 8 , TYP ( 500) » 1 , ORG‘3 
CHARACTER  CAO( 500) *2 , NAME ( 500 ) *20, QAR( 500) "5 , CMOTY ( 500) *2 
CHARACTER  PVN(500)*1 

INTCGFR  MONTH! 500). YEAR! 500). DEGREE (500). YR,GRP( 500), I  SI ZR( 500) 
INTfGCR  NOAR  (500) 

RL At  EFf (  13,500) ,5CCCUM( 1 1.3) ,BRACUM( 1 1 ),0I VCUM( 1 1 ) ,RLGCUM(  1 1 ) 

real  nmrtr,  onmntr.  rswgt 

SECT  =  SECT+RE AL ( IRESCT )  +  REAL( NRESCT  )/5.0 

RSWGT  =■ .  2 

DO  1  .J=  1  ,  11 

NMRTR= ( SECCUM( J . 1 )+RSWGT*SECCUM( J , 2 ) ) 

DNMNTR=( REAL! IRESCT )+RSWGT*REAL (NRESCT )+. 00001 ) 

SECCUM( J . 3 ) =NMRTR/DNMNTR 

SECCUM( J , 1 ) = SECCUM ( J,1)/(REAL( IRESCT )+ . 00001 ) 

SECCUM( J , 2 )= SECCUM ( J ,2)/(REAL(NRESCT)+, 00001 ) 

BRA CUM ( U ) =BRACUM( U)+SECCUM( J , 3)*(REAL(IRESCT )+REAL( NRESCT )/5 . 0) 
1  CONTINUE 


ujd  t  tc  ( c  5 )  ORGCD ( I  -  1  ) ,  SECCUM ( 7 , 1 )  .  SECCUM(  8,1),  SECCUM!  2,1), 

1  SECCUM! 5. 1 ) , SECCUM (4 , i) ,SECCUM(3, i ), SECCUM! 6, 1 ), SECCUM! 9, i ) 

5  FORMAT  (  '  '  ,  13(  ' . '). - /'  WTO  AVG  '.3X.A3/'  ' 

1'  RESIDENT' , 2 IX , 7 ( F5 . 1,3X),2X,F5. 1) 

WRITE (6 , 1 1 )  SECCUM( 7 , 2 ) , 5ECCUM( 8,2) , SECCUM( 2,2), SECCUM( 5 , 2 ) , 
1 SECCUM( 4,2), SECCUM( 3.2), SECCUM(6 , 2 ) , SECCUM( 9 , 2 ) 

11  FORMAT ( '  ' .5X, 'NONRESIDENT' , 18X,7(F5. 1 ,3X) ,2X,F5. 1 ) 

WRITE (6. 12)  SECCUM( 7 , 3 ) , SECCUM( 8,3), SECCUM! 2,3), SECCUM( 5,3), 


iSECCUMt  4 , 3 ) , SECCUM! 3,3), SECCUM( 6 , 3 ) , SECCUM<  9,3) 


1?  FORMAT!'  ' ,5X, 'COMBINED  ' . 18X . 7 ( F5 . 1 , 3X  ) . 2X , F5 . 1 ) 

100  WRITE! 14,7)  ORGCD ( I  1 ) .SECCUM! 1 , 1 ) .SECCUM! 2. 1 ) .SECCUM! 3. 1 ) . 


02110099 
02130099 
02140099 
02150099 
02160099 
02170099 
02180099 
02190099 
02200099 
02210099 
02220099 
02230099 
02231099 
02240099 
02250099 
02260099 
02261099 
02270099 
02280099 
02290099 
02300099 
02310099 
02320099 
02330099 
02340099 
02350099 
02360099 
02370099 
02380099 
<'2390099 
02390199 
02391099 
02392099 
02393099 
02394099 
02395099 
02396099 
02397099 
02398099 
02399099 
02399199 
02399299 
02399399 
02399499 
02399599 
02399699 
02399799 
02400099 
02410099 
02420099 
02430099 
02440099 
02450099 
02460099 
02461099 
02470099 
02480099 
02490099 
02500099 
02510099 
02520099 
02530099 
02E 40099 
02550099 
02560099 
02570099 
02580099 
02590099 
02600099 
0265 1 099 
02652099 
02654099 
02655099 
02691099 
02692099 
02694099 
02731099 
02732099 
02734099 
02740099 


W-hb 


1  $ECCUM(  >1 ,  1  ) ,  SECCUM( 5  ,  1),SECCUM(6,  1),SECCUM(7,  1),SECCUM(8,  1). 
2SECCUM(9. 1 ) . SECCUM( 10,1 ) ,SECCUM( 11,1 ) . YEAR( 1-1 ) , M0NTH( I -  1 ) 

7  F0RMAT(A3,  'IRES  1  SECTION  SUMMARY  1 '  .  1 1(F5. 1 , 'V  ) .  '  t  1', 
12(12, 'I' ), '41  ') 

WR I TE ( 14 , 8 )  ORGCD( I -  1 ) , SECCUM( 1,2), SECCUM( 2,2), SECCUM( 3,2), 

1 SECCUM( 4.2), SECCUM( 5.2), SECCUM( 6 . 2 ) , SECCUM( 7 , 2 ) , SECCUM(8 . 2 ) . 
2SECCUM( 9,2), SECCUM1 10,2). SECCUM( 11, 2), YEAR (1-1) , MONTH ( I -  1 ) 

8  FORMAT ( A3 ,  ' TN/R  TSECTION  SUMMARY  t ' ,  1 1  (F5 . 1 . ' 1 '  )  , '  1  1'. 
12(12. 't' ). '4t  ' ) 

WRITE ( 14,9)  ORGCD( I- 1 ) , SECCUM( 1,3), SECCUM(2 , 3 ) , SECCUM( 3,3), 
1SECCUM( 4,3), SECCUM(5 . 3) , SECCUM(6 ,  3 )  , SECCUM( 7,3), SECCUM(8 , 3 ) , 
2SECCUM(9 , 3 ) . SECCUM( 10,3) ,SECCUM( 1 1 , 3 ) . YEAR( I  -  1 ) . MONTH( I -  1 ) 

9  FORMAT ( A3 , ' TAGG  1SECTI0N  SUMMARY  t ' , 1  1  ( F5 . 1 . ' 1 ' ) . '  T  T'. 
12(12, 'T' ). '41  ') 

ORG=ORGCD( I  -  1 ) 

M0N=M0NTH(I-1 ) 

YR  =  YEAR( I -  1 ) 

ORGCD( 1 )=ORGCD(  I  ) 

F  SCM( 1 )=FSCM( I ) 

YEAR(  1  )  =  YEAR ( I ) 

MONTH( 1 )=MONTH(  I  ) 

TYP(  1  )=TYP( I ) 

<  J  A  R  (  1 )‘OAR( 1  ) 
cmi) i  y ( i  )»CMi>ry(  l  ) 
l'VN(  I  I-PVN1  1  ) 

NOAR ( 1 )=NQAR( 1 ) 

:SIZR(1)=ISIZR(1) 

GRP( 1 ) =GRP( I  ) 

DEGREE( 1)=DEGREE(1) 

FLAG( 1 )=FLAG( I  ) 

CAO( 1 )=CAO( I ) 

NAME ( 1 )=NAME( I ) 

EFF (  12. 1  )  =  EFF(  12  . 1 ) 

EFF (  13. 1 ) =EFF (  13,1) 

DO  20  0=1. 11 
EFF ( d , 1 ) =EFF ( d .  I  ) 

IF  (TYP( 1)  .EQ.  'R' )  THEN 

IF(ISIZR(1)  . EO.  625)  GRP(1)=991 
I RESCT 1 (MOD( ( I  SI ZR ( 1 )+4 ) . 5  )+ 1 ) *‘2 
NRESCT'O 

SECCUM(J. 1 )=EFF(d, 1 )  *REAL( IRESCT ) 

SECCUM(d,2)=0 

ELSE 

IRESCT =0 
NRESCT ■ 1 
SECCUM(d, 1  )=0 
SECCUM(d.2)=EFF(d,  1) 

END  IF 

20  CONTINUE 
RETURN 
END 

SUBROUTINE  BRATOT(BRACUM, BRAN. SECT , 01 VCUM, ORG . MON. YR ) 

REAL  6RACUM( 1 1 ) ,DIVCUM( 11) 

INTEGER  YR 
CHARACTER  ORG'3 
DO  10  K=1 , 1 1 

DIVCUM(K)=DIVCUM(K)+BRACUM(K) 

BRACUM( K ) =BRACUM(K )/SECT 
10  CONTINUE 

WRITE ( 6 , 15)  ORG( 1:2) 

15  FORMAT  (  '  '  ,  1 3  (  . WTO  AVG' ,  '  ',2X,A2> 

WRITE ( 6 . 40)  BRACUM( 7 ) , BRACUM( 8 ) , BRACUM( 2 ) , BRACUMf  5 ) , 

1BRACUM1 4 ) , BRACUM( 3 ) , BRACUM( 6 ) , BRACUM( 9 ) 

40  FORMAT ( '+' , 34X , 7 ( F5 . 1 , 3X ) , 2X . F5 . 1 ) 

50  WRITE ( 14,41 )  ORG( 1:2) ,BRACUM( 1 ) , BRACUM( 2 ) , BRACUM( 3 ) , BRACUM(4 ) , 
1BRACUM( 5 ) , BRACUM(6) , BRACUM( 7 ) ,BRACUM( 8 ) , BRACUM( 9 ) , BRACUM( 10) , 
2BRACUM( 1 1 ) , YR , MON 

4<  F0RMAT(A2.'  TB°  1 ' , 18X . ' r '  . 1 1 < F5  ?  t ' . 2< 12 . ' 1 ' > . ' 31 

DO  16  0=1,11 
BRACUM(d)=0.0 

16  CONTINUE 
BRAN=BRAN+SECT 
SECT =0.0 
RETURN 

END 

SUBROUTINE  DIVTOT (01 VCUM, DIVN, BRAN, REGCUM.ORG, MON, YR ) 

REAL  DIVCUM( 11), REGCUM( 11) 

INTEGER  YR 
CHARACTER  0RG*3 
DO  10  K  = 1 . 11 


02750099 
02760099 
02770099 
02780099 
02790099 
02800099 
02810099 
02820099 
02830099 
02840099 
02850099 
02860099 
02870099 
02880099 
02890099 
02900099 
02910099 
02920099 
02930099 
02940099 
02950099 
02960099 
02961099 
O2$j0?O«j<I 
02963099 
02964099 
0297C099 
02980099 
02990099 
03000099 
03010099 
03020099 
03041099 
03042099 
03050099 
03060099 
03070099 
03080099 
03090099 
03100099 
03110099 
03120099 
03 1 30099 
03140099 
03150099 
03160099 
03170099 
03180099 
03190099 
03200099 
03210099 
03220099 
03230099 
03240099 
03250099 
03260099 
03270099 
03280099 
03290099 
03300099 
03310099 
03341099' 
03342099 
03343099' 
03350099 
03360099 
03370099 
' )  03380099 
03390099 
03400099 
034 10099 
03420099 
034300^9 
03440099 
03450099 
03460099 
03470099 
03480099 
0349009 9 
03500099 
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REGCUM(K)=REGCUM(K)+OIVCUM(K) 

DIVCUM(K)=DIVCUM(K)/BRAN 
10  CONTINUE 

WRITE(6 , 35 )  ORG(  1:1) 

35  FORMAT(  '  '  .  1 3( ' - WTD  AVG' .  '  '.2X.A1) 

WRITE (6, 40)  01 VCUM( 7 ) , DI VCUM(8 ) , DIVCUM( 2) , DI VCUM( 5 ) . 

ID! VCUM! 4 ) ,D1 VCUM( 3 ) , DI VCUM(6 ) ,01 VCUM( 9 ) 

40  FORMAT! , 34X, 7! F5 . 1.3X),2X.F5  1) 

50  WRITE! 14.60)  ORG! 1 : 1 ) .OIVCUM( 1 ) , DI VCUM( 2 ) ,D1 VCUM! 3 ) , DI VCUM! 4  ) . 
101 VCUM( 5 ) , DI VCUM! 6 ) . DI VCUM( 7 ) , DI VCUM( 8 ) , DI VCUM( 9 ) , DI VCUM! 10) . 
2D1VCUM! 1 1 ),YR,MON 

60  FORMAT! A 1 . '  1DI V  1 ' . 18X . ' 1  ' , 11  (F5 .  1 .  '  t  ‘  )  .  '  t  T ' . 2( 12, ' t ' ) . ' 2T 
DO  36  0=1,11 
DIVCUM! J)=0.0 

36  CONTINUE 
0IVN*DIVN+6RAN 
BRAN>=0.0 
RETURN 

END 

SUBROUTINE  REGTOT ( REGCUM . DI VN . MON . YR ) 

REAL  REGCUM! 11) 

INTEGER  YR 
DO  10  K=1 . 1 1 

REGCUM! K)=REGCUM(K)/OIVN 
10  CONTINUE 

WRITE(6.45)  MON, YR 

45  FORMAT!'  '  .  13(  . . ),'--'/'  REGION  SUMMARY  '.3X.2I3) 

WRITE (6. 40)  REGCUM! 7 ) , REGCUM! 6 ) , REGCUM! 2 ) , REGCUM! 5) . 

1 REGCUM! 4 ) , REGCUM! 3 ) . REGCUM! 6 ) . REGCUM(9 ) 

40  FORMAT ( ' + ' . 34X , 7 ( F5 . 1 . 3X ) , 2X , F5 . 1 ) 

50  WRITE ( 14 . 4 1 )  REGCUM! 1 ) . REGCUM! 2 ) . REGCUM! 3 ) . REGCUM! 4 ) , REGCUM! 5 ) . 
1 REGCUM! 6 ) .REGCUM! 7 ) . REGCUM! 8 ) , REGCUM(9 ) , REGCUM! 10) .REGCUM! 11). 
2YR.M0N 

4!  FORMAT ( ' - --T  1REGI0N  ROLLUP  1 ' , 1 1 ( F5 . 1 . ' T ' ) . '  1  1'. 

12! 12.  'T'  ) .  '  11  '  ) 

DO  46  0*1.11 
REGCUM! J)=0.0 

46  CONTINUE 
DI VN=0.0 
RETURN 
END 


03510099 
03520099 
03530099 
03540099 
03550099 
03581099 
03582099 
03583099 
03590099 
03600099 
03610099 
' J03620099 
03630099 
03640099 
03650099 
03660099 
03670099 
03680099 
03690099 
03700099 
03710099 
03720099 
03730099 
03740099 
03750099 
03760099 
03770099 
03801099 
03802099 
03803099 
03810099 
03820099 
03830099 
03840099 
03850099 
03860099 
03870099 
03880099 
03B90099 
03900099 
03910099 
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